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 28 69 6e 63 6c 75 64 65 20 port)).(include
0420: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0430: 73 63 6d 22 29 0a 0a 3b 3b 0a 3b 3b 20 54 48 45 scm")..;;.;; THE
0440: 53 45 20 41 52 45 20 41 4c 4c 20 43 41 4c 4c 45 SE ARE ALL CALLE
0450: 44 20 4f 4e 20 54 48 45 20 43 4c 49 45 4e 54 20 D ON THE CLIENT
0460: 53 49 44 45 21 21 21 0a 3b 3b 0a 0a 3b 3b 20 67 SIDE!!!.;;..;; g
0470: 65 6e 65 72 61 74 65 20 65 6e 74 72 69 65 73 20 enerate entries
0480: 66 6f 72 20 7e 2f 2e 6d 65 67 61 74 65 73 74 72 for ~/.megatestr
0490: 63 20 77 69 74 68 20 74 68 65 20 66 6f 6c 6c 6f c with the follo
04a0: 77 69 6e 67 0a 3b 3b 0a 3b 3b 20 20 67 72 65 70 wing.;;.;; grep
04b0: 20 64 65 66 69 6e 65 20 2e 2e 2f 72 6d 74 2e 73 define ../rmt.s
04c0: 63 6d 20 7c 20 67 72 65 70 20 72 6d 74 3a 20 7c cm | grep rmt: |
04d0: 70 65 72 6c 20 2d 70 69 20 2d 65 20 27 73 2f 5c perl -pi -e 's/\
04e0: 28 64 65 66 69 6e 65 5c 73 2b 5c 28 28 5c 53 2b (define\s+\((\S+
04f0: 29 5c 57 2e 2a 24 2f 5c 31 2f 27 7c 73 6f 72 74 )\W.*$/\1/'|sort
0500: 20 2d 75 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d -u..;;=========
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
0550: 20 20 53 20 55 20 50 20 50 20 4f 20 52 20 54 20 S U P P O R T
0560: 20 20 46 20 55 20 4e 20 43 20 54 20 49 20 4f 20 F U N C T I O
0570: 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N S.;;==========
0580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
05c0: 20 69 66 20 61 20 73 65 72 76 65 72 20 69 73 20 if a server is
05d0: 65 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f either running o
05e0: 72 20 69 6e 20 74 68 65 20 70 72 6f 63 65 73 73 r in the process
05f0: 20 6f 66 20 73 74 61 72 74 69 6e 67 20 63 61 6c of starting cal
0600: 6c 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 0a 3b l client:setup.;
0610: 3b 20 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 ; else return #f
0620: 20 74 6f 20 6c 65 74 20 74 68 65 20 63 61 6c 6c to let the call
0630: 69 6e 67 20 70 72 6f 63 20 6b 6e 6f 77 20 74 68 ing proc know th
0640: 61 74 20 74 68 65 72 65 20 69 73 20 6e 6f 20 73 at there is no s
0650: 65 72 76 65 72 20 61 76 61 69 6c 61 62 6c 65 0a erver available.
0660: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;;.(define (rmt:
0670: 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 get-connection-i
0680: 6e 66 6f 20 61 72 65 61 70 61 74 68 20 23 21 6b nfo areapath #!k
0690: 65 79 20 28 61 72 65 61 2d 64 61 74 20 23 66 29 ey (area-dat #f)
06a0: 29 20 3b 3b 20 54 4f 44 4f 3a 20 70 75 73 68 20 ) ;; TODO: push
06b0: 61 72 65 61 70 61 74 68 20 64 6f 77 6e 2e 0a 20 areapath down..
06c0: 20 28 6c 65 74 2a 20 28 28 72 75 6e 72 65 6d 6f (let* ((runremo
06d0: 74 65 20 28 6f 72 20 61 72 65 61 2d 64 61 74 20 te (or area-dat
06e0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 09 20 *runremote*))..
06f0: 28 63 69 6e 66 6f 20 20 20 20 20 28 69 66 20 28 (cinfo (if (
0700: 72 65 6d 6f 74 65 3f 20 72 75 6e 72 65 6d 6f 74 remote? runremot
0710: 65 29 0a 09 09 09 28 72 65 6d 6f 74 65 2d 63 6f e)....(remote-co
0720: 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 nndat runremote)
0730: 0a 09 09 09 23 66 29 29 29 0a 09 20 20 28 69 66 ....#f))).. (if
0740: 20 63 69 6e 66 6f 0a 09 20 20 20 20 20 20 63 69 cinfo.. ci
0750: 6e 66 6f 0a 09 20 20 20 20 20 20 28 69 66 20 28 nfo.. (if (
0760: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
0770: 72 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 running areapath
0780: 29 0a 09 09 20 20 28 63 6c 69 65 6e 74 3a 73 65 )... (client:se
0790: 74 75 70 20 61 72 65 61 70 61 74 68 29 0a 09 09 tup areapath)...
07a0: 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))..(defin
07b0: 65 20 2a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d e *send-receive-
07c0: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
07d0: 65 78 29 29 20 3b 3b 20 73 68 6f 75 6c 64 20 68 ex)) ;; should h
07e0: 61 76 65 20 73 65 70 61 72 61 74 65 20 6d 75 74 ave separate mut
07f0: 65 78 20 70 65 72 20 72 75 6e 2d 69 64 0a 0a 3b ex per run-id..;
0800: 3b 20 52 41 20 3d 3e 20 65 2e 67 2e 20 75 73 61 ; RA => e.g. usa
0810: 67 65 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 ge (rmt:send-rec
0820: 65 69 76 65 20 27 67 65 74 2d 76 61 72 20 23 66 eive 'get-var #f
0830: 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 29 (list varname))
0840: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 .;;.(define (rmt
0850: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d :send-receive cm
0860: 64 20 72 69 64 20 70 61 72 61 6d 73 20 23 21 6b d rid params #!k
0870: 65 79 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 31 ey (attemptnum 1
0880: 29 28 61 72 65 61 2d 64 61 74 20 23 66 29 29 20 )(area-dat #f))
0890: 3b 3b 20 73 74 61 72 74 20 61 74 74 65 6d 70 74 ;; start attempt
08a0: 6e 75 6d 20 61 74 20 31 20 73 6f 20 74 68 65 20 num at 1 so the
08b0: 6d 6f 64 75 6c 6f 20 62 65 6c 6f 77 20 77 6f 72 modulo below wor
08c0: 6b 73 20 61 73 20 65 78 70 65 63 74 65 64 0a 0a ks as expected..
08d0: 20 20 28 63 6f 6d 6d 6f 6e 3a 74 65 6c 65 6d 65 (common:teleme
08e0: 74 72 79 2d 6c 6f 67 20 28 63 6f 6e 63 20 22 72 try-log (conc "r
08f0: 6d 74 3a 22 28 2d 3e 73 74 72 69 6e 67 20 63 6d mt:"(->string cm
0900: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
0910: 20 20 20 20 20 20 20 20 20 20 20 20 70 61 79 6c payl
0920: 6f 61 64 3a 20 60 28 28 72 69 64 20 2e 20 2c 72 oad: `((rid . ,r
0930: 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 id).
0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0950: 20 20 20 20 20 20 20 28 70 61 72 61 6d 73 20 2e (params .
0960: 20 2c 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 ,params))).
0970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0980: 20 20 20 20 20 20 0a 20 20 0a 20 20 3b 3b 44 4f . . ;;DO
0990: 54 20 64 69 67 72 61 70 68 20 6d 65 67 61 74 65 T digraph megate
09a0: 73 74 5f 73 74 61 74 65 5f 73 74 61 74 75 73 20 st_state_status
09b0: 7b 0a 20 20 3b 3b 44 4f 54 20 20 20 72 61 6e 6b {. ;;DOT rank
09c0: 73 65 70 3d 30 3b 0a 20 20 3b 3b 44 4f 54 20 20 sep=0;. ;;DOT
09d0: 20 2f 2f 20 72 61 6e 6b 64 69 72 3d 4c 52 3b 0a // rankdir=LR;.
09e0: 20 20 3b 3b 44 4f 54 20 20 20 6e 6f 64 65 20 5b ;;DOT node [
09f0: 73 68 61 70 65 3d 22 62 6f 78 22 5d 3b 0a 20 20 shape="box"];.
0a00: 3b 3b 44 4f 54 20 22 72 6d 74 3a 73 65 6e 64 2d ;;DOT "rmt:send-
0a10: 72 65 63 65 69 76 65 22 20 2d 3e 20 4d 55 54 45 receive" -> MUTE
0a20: 58 4c 4f 43 4b 3b 0a 20 20 3b 3b 44 4f 54 20 7b XLOCK;. ;;DOT {
0a30: 20 65 64 67 65 20 5b 73 74 79 6c 65 3d 69 6e 76 edge [style=inv
0a40: 69 73 5d 3b 22 63 61 73 65 20 31 22 20 2d 3e 20 is];"case 1" ->
0a50: 22 63 61 73 65 20 32 22 20 2d 3e 20 22 63 61 73 "case 2" -> "cas
0a60: 65 20 33 22 20 2d 3e 20 22 63 61 73 65 20 34 22 e 3" -> "case 4"
0a70: 20 2d 3e 20 22 63 61 73 65 20 35 22 20 2d 3e 20 -> "case 5" ->
0a80: 22 63 61 73 65 20 36 22 20 2d 3e 20 22 63 61 73 "case 6" -> "cas
0a90: 65 20 37 22 20 2d 3e 20 22 63 61 73 65 20 38 22 e 7" -> "case 8"
0aa0: 20 2d 3e 20 22 63 61 73 65 20 39 22 20 2d 3e 20 -> "case 9" ->
0ab0: 22 63 61 73 65 20 31 30 22 20 2d 3e 20 22 63 61 "case 10" -> "ca
0ac0: 73 65 20 31 31 22 3b 20 7d 0a 20 20 3b 3b 20 64 se 11"; }. ;; d
0ad0: 6f 20 61 6c 6c 20 74 68 65 20 70 72 65 70 20 6c o all the prep l
0ae0: 6f 63 6b 65 64 20 75 6e 64 65 72 20 74 68 65 20 ocked under the
0af0: 72 6d 74 2d 6d 75 74 65 78 0a 20 20 28 6d 75 74 rmt-mutex. (mut
0b00: 65 78 2d 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 ex-lock! *rmt-mu
0b10: 74 65 78 2a 29 0a 20 20 0a 20 20 3b 3b 20 31 2e tex*). . ;; 1.
0b20: 20 63 68 65 63 6b 20 69 66 20 73 65 72 76 65 72 check if server
0b30: 20 69 73 20 73 74 61 72 74 65 64 20 49 46 46 20 is started IFF
0b40: 63 6d 64 20 69 73 20 61 20 77 72 69 74 65 20 4f cmd is a write O
0b50: 52 20 69 66 20 77 65 20 61 72 65 20 6e 6f 74 20 R if we are not
0b60: 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 2c on the homehost,
0b70: 20 73 74 6f 72 65 20 69 6e 20 72 75 6e 72 65 6d store in runrem
0b80: 6f 74 65 0a 20 20 3b 3b 20 32 2e 20 63 68 65 63 ote. ;; 2. chec
0b90: 6b 20 74 68 65 20 61 67 65 20 6f 66 20 74 68 65 k the age of the
0ba0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 2e 20 72 65 connections. re
0bb0: 66 72 65 73 68 20 74 68 65 20 63 6f 6e 6e 65 63 fresh the connec
0bc0: 74 69 6f 6e 20 69 66 20 69 74 20 69 73 20 6f 6c tion if it is ol
0bd0: 64 65 72 20 74 68 61 6e 20 74 69 6d 65 6f 75 74 der than timeout
0be0: 2d 32 30 20 73 65 63 6f 6e 64 73 2e 0a 20 20 3b -20 seconds.. ;
0bf0: 3b 20 33 2e 20 64 6f 20 74 68 65 20 71 75 65 72 ; 3. do the quer
0c00: 79 2c 20 69 66 20 6f 6e 20 68 6f 6d 65 68 6f 73 y, if on homehos
0c10: 74 20 75 73 65 20 6c 6f 63 61 6c 20 61 63 63 65 t use local acce
0c20: 73 73 0a 20 20 3b 3b 0a 20 20 28 6c 65 74 2a 20 ss. ;;. (let*
0c30: 28 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 20 ((start-time
0c40: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
0c50: 29 29 20 3b 3b 20 73 6e 61 70 73 68 6f 74 20 74 )) ;; snapshot t
0c60: 69 6d 65 20 73 6f 20 61 6c 6c 20 75 73 65 20 63 ime so all use c
0c70: 61 73 65 73 20 67 65 74 20 73 61 6d 65 20 76 61 ases get same va
0c80: 6c 75 65 0a 20 20 20 20 20 20 20 20 20 28 61 72 lue. (ar
0c90: 65 61 70 61 74 68 20 20 20 20 20 20 2a 74 6f 70 eapath *top
0ca0: 70 61 74 68 2a 29 3b 3b 20 54 4f 44 4f 20 2d 20 path*);; TODO -
0cb0: 72 65 73 6f 6c 76 65 20 66 72 6f 6d 20 64 62 73 resolve from dbs
0cc0: 74 72 75 63 74 20 74 6f 20 62 65 20 63 6f 6d 70 truct to be comp
0cd0: 61 74 69 62 6c 65 20 77 69 74 68 20 6d 75 6c 74 atible with mult
0ce0: 69 70 6c 65 20 61 72 65 61 73 0a 09 20 28 72 75 iple areas.. (ru
0cf0: 6e 72 65 6d 6f 74 65 20 20 20 20 20 28 6f 72 20 nremote (or
0d00: 61 72 65 61 2d 64 61 74 0a 09 09 09 20 20 20 20 area-dat....
0d10: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 09 20 *runremote*))..
0d20: 28 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 28 (readonly-mode (
0d30: 69 66 20 28 61 6e 64 20 72 75 6e 72 65 6d 6f 74 if (and runremot
0d40: 65 0a 09 09 09 09 20 28 72 65 6d 6f 74 65 2d 72 e..... (remote-r
0d50: 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b 65 64 20 72 o-mode-checked r
0d60: 75 6e 72 65 6d 6f 74 65 29 29 0a 09 09 09 20 20 unremote))....
0d70: 20 20 28 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 (remote-ro-mod
0d80: 65 20 72 75 6e 72 65 6d 6f 74 65 29 0a 09 09 09 e runremote)....
0d90: 20 20 20 20 28 6c 65 74 2a 20 28 28 64 62 66 69 (let* ((dbfi
0da0: 6c 65 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 le (conc *toppa
0db0: 74 68 2a 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 th* "/megatest.d
0dc0: 62 22 29 29 0a 09 09 09 09 20 20 20 28 72 6f 2d b"))..... (ro-
0dd0: 6d 6f 64 65 20 28 6e 6f 74 20 28 66 69 6c 65 2d mode (not (file-
0de0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 write-access? db
0df0: 66 69 6c 65 29 29 29 29 20 3b 3b 20 54 4f 44 4f file)))) ;; TODO
0e00: 3a 20 75 73 65 20 64 62 73 74 72 75 63 74 20 6f : use dbstruct o
0e10: 72 20 72 75 6e 72 65 6d 6f 74 65 20 74 6f 20 66 r runremote to f
0e20: 69 67 75 72 65 20 74 68 69 73 20 6f 75 74 20 69 igure this out i
0e30: 6e 20 66 75 74 75 72 65 0a 09 09 09 20 20 20 20 n future....
0e40: 20 20 28 69 66 20 72 75 6e 72 65 6d 6f 74 65 0a (if runremote.
0e50: 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
0e60: 09 20 20 20 20 28 72 65 6d 6f 74 65 2d 72 6f 2d . (remote-ro-
0e70: 6d 6f 64 65 2d 73 65 74 21 20 72 75 6e 72 65 6d mode-set! runrem
0e80: 6f 74 65 20 72 6f 2d 6d 6f 64 65 29 0a 09 09 09 ote ro-mode)....
0e90: 09 20 20 20 20 28 72 65 6d 6f 74 65 2d 72 6f 2d . (remote-ro-
0ea0: 6d 6f 64 65 2d 63 68 65 63 6b 65 64 2d 73 65 74 mode-checked-set
0eb0: 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 74 29 0a ! runremote #t).
0ec0: 09 09 09 09 20 20 20 20 72 6f 2d 6d 6f 64 65 29 .... ro-mode)
0ed0: 0a 09 09 09 09 20 20 72 6f 2d 6d 6f 64 65 29 29 ..... ro-mode))
0ee0: 29 29 29 0a 0a 20 20 20 20 3b 3b 20 44 4f 54 20 ))).. ;; DOT
0ef0: 49 4e 49 54 5f 52 55 4e 52 45 4d 4f 54 45 3b 20 INIT_RUNREMOTE;
0f00: 2f 2f 20 6c 65 61 76 69 6e 67 20 6f 66 66 20 2d // leaving off -
0f10: 20 64 6f 65 73 6e 27 74 20 72 65 61 6c 6c 79 20 doesn't really
0f20: 61 64 64 20 74 6f 20 74 68 65 20 63 6c 61 72 69 add to the clari
0f30: 74 79 0a 20 20 20 20 3b 3b 20 44 4f 54 20 4d 55 ty. ;; DOT MU
0f40: 54 45 58 4c 4f 43 4b 20 2d 3e 20 49 4e 49 54 5f TEXLOCK -> INIT_
0f50: 52 55 4e 52 45 4d 4f 54 45 20 5b 6c 61 62 65 6c RUNREMOTE [label
0f60: 3d 22 6e 6f 20 72 65 6d 6f 74 65 3f 22 5d 3b 0a ="no remote?"];.
0f70: 20 20 20 20 3b 3b 20 44 4f 54 20 49 4e 49 54 5f ;; DOT INIT_
0f80: 52 55 4e 52 45 4d 4f 54 45 20 2d 3e 20 4d 55 54 RUNREMOTE -> MUT
0f90: 45 58 4c 4f 43 4b 3b 0a 20 20 20 20 3b 3b 20 65 EXLOCK;. ;; e
0fa0: 6e 73 75 72 65 20 77 65 20 68 61 76 65 20 61 20 nsure we have a
0fb0: 72 65 63 6f 72 64 20 66 6f 72 20 6f 75 72 20 63 record for our c
0fc0: 6f 6e 6e 65 63 74 69 6f 6e 20 66 6f 72 20 67 69 onnection for gi
0fd0: 76 65 6e 20 61 72 65 61 0a 20 20 20 20 28 69 66 ven area. (if
0fe0: 20 28 6e 6f 74 20 72 75 6e 72 65 6d 6f 74 65 29 (not runremote)
0ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1000: 20 20 20 3b 3b 20 63 61 6e 20 72 65 6d 6f 76 65 ;; can remove
1010: 20 74 68 69 73 20 6f 6e 65 2e 20 73 68 6f 75 6c this one. shoul
1020: 64 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 d never get here
1030: 2e 20 20 20 20 20 20 20 20 20 0a 09 28 62 65 67 . ..(beg
1040: 69 6e 0a 09 20 20 28 73 65 74 21 20 2a 72 75 6e in.. (set! *run
1050: 72 65 6d 6f 74 65 2a 20 28 6d 61 6b 65 2d 72 65 remote* (make-re
1060: 6d 6f 74 65 29 29 0a 09 20 20 28 73 65 74 21 20 mote)).. (set!
1070: 72 75 6e 72 65 6d 6f 74 65 20 20 20 2a 72 75 6e runremote *run
1080: 72 65 6d 6f 74 65 2a 29 29 29 20 3b 3b 20 6e 65 remote*))) ;; ne
1090: 77 20 72 75 6e 72 65 6d 6f 74 65 20 77 69 6c 6c w runremote will
10a0: 20 63 6f 6d 65 20 66 72 6f 6d 20 74 68 69 73 20 come from this
10b0: 6f 6e 20 6e 65 78 74 20 69 74 65 72 61 74 69 6f on next iteratio
10c0: 6e 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 44 4f n. . ;; DO
10d0: 54 20 53 45 54 5f 48 4f 4d 45 48 4f 53 54 3b 20 T SET_HOMEHOST;
10e0: 2f 2f 20 6c 65 61 76 69 6e 67 20 6f 66 66 20 2d // leaving off -
10f0: 20 64 6f 65 73 6e 27 74 20 72 65 61 6c 6c 79 20 doesn't really
1100: 61 64 64 20 74 6f 20 74 68 65 20 63 6c 61 72 69 add to the clari
1110: 74 79 0a 20 20 20 20 3b 3b 20 44 4f 54 20 4d 55 ty. ;; DOT MU
1120: 54 45 58 4c 4f 43 4b 20 2d 3e 20 53 45 54 5f 48 TEXLOCK -> SET_H
1130: 4f 4d 45 48 4f 53 54 20 5b 6c 61 62 65 6c 3d 22 OMEHOST [label="
1140: 6e 6f 20 68 6f 6d 65 68 6f 73 74 3f 22 5d 3b 0a no homehost?"];.
1150: 20 20 20 20 3b 3b 20 44 4f 54 20 53 45 54 5f 48 ;; DOT SET_H
1160: 4f 4d 45 48 4f 53 54 20 2d 3e 20 4d 55 54 45 58 OMEHOST -> MUTEX
1170: 4c 4f 43 4b 3b 0a 20 20 20 20 3b 3b 20 65 6e 73 LOCK;. ;; ens
1180: 75 72 65 20 77 65 20 68 61 76 65 20 61 20 68 6f ure we have a ho
1190: 6d 65 68 6f 73 74 20 72 65 63 6f 72 64 0a 20 20 mehost record.
11a0: 20 20 28 69 66 20 28 6e 6f 74 20 28 70 61 69 72 (if (not (pair
11b0: 3f 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 ? (remote-hh-dat
11c0: 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 20 20 3b runremote))) ;
11d0: 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 ; not on homehos
11e0: 74 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 t..(thread-sleep
11f0: 21 20 30 2e 31 29 20 3b 3b 20 73 69 6e 63 65 20 ! 0.1) ;; since
1200: 77 65 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 we shouldn't get
1210: 20 68 65 72 65 2c 20 64 65 6c 61 79 20 61 20 6c here, delay a l
1220: 69 74 74 6c 65 0a 09 28 72 65 6d 6f 74 65 2d 68 ittle..(remote-h
1230: 68 2d 64 61 74 2d 73 65 74 21 20 72 75 6e 72 65 h-dat-set! runre
1240: 6d 6f 74 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 mote (common:get
1250: 2d 68 6f 6d 65 68 6f 73 74 29 29 29 0a 20 20 20 -homehost))).
1260: 20 0a 20 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 . ;;(print "
1270: 42 42 3e 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 BB> readonly-mod
1280: 65 20 69 73 20 22 72 65 61 64 6f 6e 6c 79 2d 6d e is "readonly-m
1290: 6f 64 65 22 20 64 62 66 69 6c 65 20 69 73 20 22 ode" dbfile is "
12a0: 64 62 66 69 6c 65 29 0a 20 20 20 20 28 63 6f 6e dbfile). (con
12b0: 64 0a 20 20 20 20 20 3b 3b 44 4f 54 20 45 58 49 d. ;;DOT EXI
12c0: 54 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 T;. ;;DOT MU
12d0: 54 45 58 4c 4f 43 4b 20 2d 3e 20 45 58 49 54 20 TEXLOCK -> EXIT
12e0: 5b 6c 61 62 65 6c 3d 22 3e 20 31 35 20 61 74 74 [label="> 15 att
12f0: 65 6d 70 74 73 22 5d 3b 20 7b 72 61 6e 6b 3d 73 empts"]; {rank=s
1300: 61 6d 65 20 22 63 61 73 65 20 31 22 20 22 45 58 ame "case 1" "EX
1310: 49 54 22 20 7d 0a 20 20 20 20 20 3b 3b 20 67 69 IT" }. ;; gi
1320: 76 65 20 75 70 20 69 66 20 6d 6f 72 65 20 74 68 ve up if more th
1330: 61 6e 20 31 35 20 61 74 74 65 6d 70 74 73 0a 20 an 15 attempts.
1340: 20 20 20 20 28 28 3e 20 61 74 74 65 6d 70 74 6e ((> attemptn
1350: 75 6d 20 31 35 29 0a 20 20 20 20 20 20 28 64 65 um 15). (de
1360: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1370: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1380: 45 52 52 4f 52 3a 20 31 35 20 74 72 69 65 73 20 ERROR: 15 tries
1390: 74 6f 20 73 74 61 72 74 2f 63 6f 6e 6e 65 63 74 to start/connect
13a0: 20 74 6f 20 73 65 72 76 65 72 2e 20 47 69 76 69 to server. Givi
13b0: 6e 67 20 75 70 2e 22 29 0a 20 20 20 20 20 20 28 ng up."). (
13c0: 65 78 69 74 20 31 29 29 0a 0a 20 20 20 20 20 3b exit 1)).. ;
13d0: 3b 44 4f 54 20 43 41 53 45 32 20 5b 6c 61 62 65 ;DOT CASE2 [labe
13e0: 6c 3d 22 6c 6f 63 61 6c 5c 6e 72 65 61 64 6f 6e l="local\nreadon
13f0: 6c 79 5c 6e 71 75 65 72 79 22 5d 3b 0a 20 20 20 ly\nquery"];.
1400: 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 ;;DOT MUTEXLOC
1410: 4b 20 2d 3e 20 43 41 53 45 32 3b 20 7b 72 61 6e K -> CASE2; {ran
1420: 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 32 22 20 k=same "case 2"
1430: 43 41 53 45 32 7d 0a 20 20 20 20 20 3b 3b 44 4f CASE2}. ;;DO
1440: 54 20 43 41 53 45 32 20 2d 3e 20 22 72 6d 74 3a T CASE2 -> "rmt:
1450: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
1460: 6f 63 61 6c 6c 79 22 3b 0a 20 20 20 20 20 3b 3b ocally";. ;;
1470: 20 72 65 61 64 6f 6e 6c 79 20 6d 6f 64 65 2c 20 readonly mode,
1480: 72 65 61 64 20 72 65 71 75 65 73 74 2d 20 20 68 read request- h
1490: 61 6e 64 6c 65 20 69 74 20 2d 20 63 61 73 65 20 andle it - case
14a0: 32 0a 20 20 20 20 20 28 28 61 6e 64 20 72 65 61 2. ((and rea
14b0: 64 6f 6e 6c 79 2d 6d 6f 64 65 0a 20 20 20 20 20 donly-mode.
14c0: 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 63 6d (member cm
14d0: 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d d api:read-only-
14e0: 71 75 65 72 69 65 73 29 29 20 0a 20 20 20 20 20 queries)) .
14f0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
1500: 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 *rmt-mutex*).
1510: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1520: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
1530: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
1540: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
1550: 73 65 20 32 22 29 0a 20 20 20 20 20 20 28 72 6d se 2"). (rm
1560: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
1570: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 -locally cmd 0 p
1580: 61 72 61 6d 73 29 0a 20 20 20 20 20 20 29 0a 0a arams). )..
1590: 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 33 ;;DOT CASE3
15a0: 20 5b 6c 61 62 65 6c 3d 22 77 72 69 74 65 20 69 [label="write i
15b0: 6e 5c 6e 72 65 61 64 2d 6f 6e 6c 79 20 6d 6f 64 n\nread-only mod
15c0: 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 e"];. ;;DOT
15d0: 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 MUTEXLOCK -> CAS
15e0: 45 33 20 5b 6c 61 62 65 6c 3d 22 72 65 61 64 6f E3 [label="reado
15f0: 6e 6c 79 5c 6e 6d 6f 64 65 3f 22 5d 3b 20 7b 72 nly\nmode?"]; {r
1600: 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 33 ank=same "case 3
1610: 22 20 43 41 53 45 33 7d 0a 20 20 20 20 20 3b 3b " CASE3}. ;;
1620: 44 4f 54 20 43 41 53 45 33 20 2d 3e 20 22 23 66 DOT CASE3 -> "#f
1630: 22 3b 0a 20 20 20 20 20 3b 3b 20 72 65 61 64 6f ";. ;; reado
1640: 6e 6c 79 20 6d 6f 64 65 2c 20 77 72 69 74 65 20 nly mode, write
1650: 72 65 71 75 65 73 74 2e 20 20 44 6f 20 6e 6f 74 request. Do not
1660: 68 69 6e 67 2c 20 72 65 74 75 72 6e 20 23 66 0a hing, return #f.
1670: 20 20 20 20 20 28 72 65 61 64 6f 6e 6c 79 2d 6d (readonly-m
1680: 6f 64 65 0a 20 20 20 20 20 20 28 6d 75 74 65 78 ode. (mutex
1690: 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 -unlock! *rmt-mu
16a0: 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 tex*). (deb
16b0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 ug:print-info 12
16c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
16d0: 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 rt* "rmt:send-re
16e0: 63 65 69 76 65 2c 20 63 61 73 65 20 33 22 29 0a ceive, case 3").
16f0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1700: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1710: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
1720: 3a 20 77 72 69 74 65 20 74 72 61 6e 73 61 63 74 : write transact
1730: 69 6f 6e 20 72 65 71 75 65 73 74 65 64 20 6f 6e ion requested on
1740: 20 61 20 72 65 61 64 6f 6e 6c 79 20 61 72 65 61 a readonly area
1750: 2e 20 20 63 6d 64 3d 22 63 6d 64 22 20 70 61 72 . cmd="cmd" par
1760: 61 6d 73 3d 22 70 61 72 61 6d 73 29 0a 20 20 20 ams="params).
1770: 20 20 20 23 66 29 0a 0a 20 20 20 20 20 3b 3b 20 #f).. ;;
1780: 54 68 69 73 20 62 6c 6f 63 6b 20 77 61 73 20 66 This block was f
1790: 6f 72 20 70 72 65 2d 65 6d 70 74 69 76 65 6c 79 or pre-emptively
17a0: 20 72 65 73 65 74 74 69 6e 67 20 74 68 65 20 63 resetting the c
17b0: 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 74 68 65 onnection if the
17c0: 72 65 20 68 61 64 20 62 65 65 6e 20 6e 6f 20 63 re had been no c
17d0: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 6f 72 ommunication for
17e0: 20 73 6f 6d 65 20 74 69 6d 65 2e 0a 20 20 20 20 some time..
17f0: 20 3b 3b 20 49 20 64 6f 6e 27 74 20 74 68 69 6e ;; I don't thin
1800: 6b 20 69 74 20 61 64 64 73 20 61 6e 79 20 76 61 k it adds any va
1810: 6c 75 65 2e 20 49 66 20 74 68 65 20 73 65 72 76 lue. If the serv
1820: 65 72 20 69 73 20 6e 6f 74 20 74 68 65 72 65 2c er is not there,
1830: 20 6a 75 73 74 20 66 61 69 6c 20 61 6e 64 20 73 just fail and s
1840: 74 61 72 74 20 61 20 6e 65 77 20 63 6f 6e 6e 65 tart a new conne
1850: 63 74 69 6f 6e 2e 0a 20 20 20 20 20 3b 3b 20 61 ction.. ;; a
1860: 6c 73 6f 2c 20 74 68 65 20 65 78 70 69 72 65 2d lso, the expire-
1870: 74 69 6d 65 20 63 61 6c 63 75 6c 61 74 69 6f 6e time calculation
1880: 20 6d 69 67 68 74 20 6e 6f 74 20 62 65 20 63 6f might not be co
1890: 72 72 65 63 74 2e 20 57 65 20 77 61 6e 74 2c 20 rrect. We want,
18a0: 74 69 6d 65 2d 73 69 6e 63 65 2d 6c 61 73 74 2d time-since-last-
18b0: 73 65 72 76 65 72 2d 61 63 63 65 73 73 20 3e 20 server-access >
18c0: 28 73 65 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 (server:get-time
18d0: 6f 75 74 29 0a 20 20 20 20 20 3b 3b 0a 20 20 20 out). ;;.
18e0: 20 20 3b 3b 44 4f 54 20 43 41 53 45 34 20 5b 6c ;;DOT CASE4 [l
18f0: 61 62 65 6c 3d 22 72 65 73 65 74 5c 6e 63 6f 6e abel="reset\ncon
1900: 6e 65 63 74 69 6f 6e 22 5d 3b 0a 20 20 20 20 20 nection"];.
1910: 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 ;;DOT MUTEXLOCK
1920: 2d 3e 20 43 41 53 45 34 20 5b 6c 61 62 65 6c 3d -> CASE4 [label=
1930: 22 68 61 76 65 20 63 6f 6e 6e 65 63 74 69 6f 6e "have connection
1940: 2c 5c 6e 6c 61 73 74 5f 61 63 63 65 73 73 20 3e ,\nlast_access >
1950: 20 65 78 70 69 72 65 5f 74 69 6d 65 22 5d 3b 20 expire_time"];
1960: 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 {rank=same "case
1970: 20 34 22 20 43 41 53 45 34 7d 0a 20 20 20 20 20 4" CASE4}.
1980: 3b 3b 44 4f 54 20 43 41 53 45 34 20 2d 3e 20 22 ;;DOT CASE4 -> "
1990: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
19a0: 22 3b 0a 20 20 20 20 20 3b 3b 20 72 65 73 65 74 ";. ;; reset
19b0: 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 the connection
19c0: 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 75 if it has been u
19d0: 6e 75 73 65 64 20 74 6f 6f 20 6c 6f 6e 67 0a 20 nused too long.
19e0: 20 20 20 20 28 28 61 6e 64 20 72 75 6e 72 65 6d ((and runrem
19f0: 6f 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 28 ote. (
1a00: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 72 remote-conndat r
1a10: 75 6e 72 65 6d 6f 74 65 29 0a 09 20 20 20 28 3e unremote).. (>
1a20: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
1a30: 73 29 20 3b 3b 20 69 66 20 69 74 20 68 61 73 20 s) ;; if it has
1a40: 62 65 65 6e 20 6d 6f 72 65 20 74 68 61 6e 20 73 been more than s
1a50: 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 73 65 erver-timeout se
1a60: 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 conds since last
1a70: 20 63 6f 6e 74 61 63 74 2c 20 63 6c 6f 73 65 20 contact, close
1a80: 74 68 69 73 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 this connection
1a90: 61 6e 64 20 73 74 61 72 74 20 61 20 6e 65 77 20 and start a new
1aa0: 6f 6e 0a 09 20 20 20 20 20 20 28 2b 20 28 68 74 on.. (+ (ht
1ab0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
1ac0: 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 73 74 ver-dat-get-last
1ad0: 2d 61 63 63 65 73 73 20 28 72 65 6d 6f 74 65 2d -access (remote-
1ae0: 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 conndat runremot
1af0: 65 29 29 0a 09 09 20 28 72 65 6d 6f 74 65 2d 73 e))... (remote-s
1b00: 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 72 75 erver-timeout ru
1b10: 6e 72 65 6d 6f 74 65 29 29 29 29 0a 20 20 20 20 nremote)))).
1b20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
1b30: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
1b40: 6f 67 2d 70 6f 72 74 2a 20 22 43 6f 6e 6e 65 63 og-port* "Connec
1b50: 74 69 6f 6e 20 74 6f 20 22 20 28 72 65 6d 6f 74 tion to " (remot
1b60: 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e e-server-url run
1b70: 72 65 6d 6f 74 65 29 20 22 20 65 78 70 69 72 65 remote) " expire
1b80: 64 20 64 75 65 20 74 6f 20 6e 6f 20 61 63 63 65 d due to no acce
1b90: 73 73 65 73 2c 20 66 6f 72 63 69 6e 67 20 6e 65 sses, forcing ne
1ba0: 77 20 63 6f 6e 6e 65 63 74 69 6f 6e 2e 22 29 0a w connection.").
1bb0: 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e (http-tran
1bc0: 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e sport:close-conn
1bd0: 65 63 74 69 6f 6e 73 20 61 72 65 61 2d 64 61 74 ections area-dat
1be0: 3a 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 20 : runremote).
1bf0: 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 (remote-connd
1c00: 61 74 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 at-set! runremot
1c10: 65 20 23 66 29 20 3b 3b 20 69 6e 76 61 6c 69 64 e #f) ;; invalid
1c20: 61 74 65 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 ate the connecti
1c30: 6f 6e 2c 20 74 68 75 73 20 66 6f 72 63 69 6e 67 on, thus forcing
1c40: 20 61 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 6f a new connectio
1c50: 6e 2e 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d n.. (mutex-
1c60: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
1c70: 65 78 2a 29 0a 20 20 20 20 20 20 28 72 6d 74 3a ex*). (rmt:
1c80: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
1c90: 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 rid params atte
1ca0: 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e mptnum: attemptn
1cb0: 75 6d 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 um)). .
1cc0: 3b 3b 44 4f 54 20 43 41 53 45 35 20 5b 6c 61 62 ;;DOT CASE5 [lab
1cd0: 65 6c 3d 22 6c 6f 63 61 6c 5c 6e 72 65 61 64 22 el="local\nread"
1ce0: 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 ];. ;;DOT MU
1cf0: 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 35 TEXLOCK -> CASE5
1d00: 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 20 [label="server
1d10: 6e 6f 74 20 72 65 71 75 69 72 65 64 2c 5c 6e 6f not required,\no
1d20: 6e 20 68 6f 6d 65 68 6f 73 74 2c 5c 6e 72 65 61 n homehost,\nrea
1d30: 64 2d 6f 6e 6c 79 20 71 75 65 72 79 22 5d 3b 20 d-only query"];
1d40: 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 {rank=same "case
1d50: 20 35 22 20 43 41 53 45 35 7d 3b 0a 20 20 20 20 5" CASE5};.
1d60: 20 3b 3b 44 4f 54 20 43 41 53 45 35 20 2d 3e 20 ;;DOT CASE5 ->
1d70: 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c "rmt:open-qry-cl
1d80: 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 0a 20 ose-locally";..
1d90: 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f ;; on homeho
1da0: 73 74 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 st and this is a
1db0: 20 72 65 61 64 0a 20 20 20 20 20 28 28 61 6e 64 read. ((and
1dc0: 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f (not (remote-fo
1dd0: 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 rce-server runre
1de0: 6d 6f 74 65 29 29 20 3b 3b 20 68 6f 6e 6f 72 20 mote)) ;; honor
1df0: 66 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 65 forced use of se
1e00: 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 65 rver, i.e. serve
1e10: 72 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a 09 r NOT required..
1e20: 20 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 2d (cdr (remote-
1e30: 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 hh-dat runremote
1e40: 29 29 20 20 20 20 20 20 20 3b 3b 20 6f 6e 20 68 )) ;; on h
1e50: 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 20 omehost.
1e60: 20 20 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 (member cmd a
1e70: 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 pi:read-only-que
1e80: 72 69 65 73 29 29 20 20 20 3b 3b 20 74 68 69 73 ries)) ;; this
1e90: 20 69 73 20 61 20 72 65 61 64 0a 20 20 20 20 20 is a read.
1ea0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
1eb0: 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 *rmt-mutex*).
1ec0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1ed0: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
1ee0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
1ef0: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
1f00: 73 65 20 20 35 22 29 0a 20 20 20 20 20 20 28 72 se 5"). (r
1f10: 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 mt:open-qry-clos
1f20: 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 e-locally cmd 0
1f30: 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 3b params)).. ;
1f40: 3b 44 4f 54 20 43 41 53 45 36 20 5b 6c 61 62 65 ;DOT CASE6 [labe
1f50: 6c 3d 22 69 6e 69 74 5c 6e 72 65 6d 6f 74 65 22 l="init\nremote"
1f60: 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 ];. ;;DOT MU
1f70: 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 36 TEXLOCK -> CASE6
1f80: 20 5b 6c 61 62 65 6c 3d 22 6f 6e 20 68 6f 6d 65 [label="on home
1f90: 68 6f 73 74 2c 5c 6e 77 72 69 74 65 20 71 75 65 host,\nwrite que
1fa0: 72 79 2c 5c 6e 68 61 76 65 20 73 65 72 76 65 72 ry,\nhave server
1fb0: 2c 5c 6e 63 61 6e 27 74 20 72 65 61 63 68 20 69 ,\ncan't reach i
1fc0: 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 t"]; {rank=same
1fd0: 22 63 61 73 65 20 36 22 20 43 41 53 45 36 7d 3b "case 6" CASE6};
1fe0: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 . ;;DOT CASE
1ff0: 36 20 2d 3e 20 22 72 6d 74 3a 73 65 6e 64 2d 72 6 -> "rmt:send-r
2000: 65 63 65 69 76 65 22 3b 0a 20 20 20 20 20 3b 3b eceive";. ;;
2010: 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 on homehost and
2020: 20 74 68 69 73 20 69 73 20 61 20 77 72 69 74 65 this is a write
2030: 2c 20 77 65 20 61 6c 72 65 61 64 79 20 68 61 76 , we already hav
2040: 65 20 61 20 73 65 72 76 65 72 2c 20 62 75 74 20 e a server, but
2050: 73 65 72 76 65 72 20 68 61 73 20 64 69 65 64 0a server has died.
2060: 20 20 20 20 20 28 28 61 6e 64 20 28 63 64 72 20 ((and (cdr
2070: 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 (remote-hh-dat r
2080: 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 20 20 unremote))
2090: 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 ;; on homeh
20a0: 6f 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 28 ost. (
20b0: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 not (member cmd
20c0: 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 api:read-only-qu
20d0: 65 72 69 65 73 29 29 20 20 3b 3b 20 74 68 69 73 eries)) ;; this
20e0: 20 69 73 20 61 20 77 72 69 74 65 0a 20 20 20 20 is a write.
20f0: 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 73 (remote-s
2100: 65 72 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 6d erver-url runrem
2110: 6f 74 65 29 20 20 20 20 20 20 20 20 20 20 20 20 ote)
2120: 20 3b 3b 20 68 61 76 65 20 61 20 73 65 72 76 65 ;; have a serve
2130: 72 0a 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f r. (no
2140: 74 20 28 73 65 72 76 65 72 3a 70 69 6e 67 20 28 t (server:ping (
2150: 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 remote-server-ur
2160: 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 l runremote))))
2170: 20 3b 3b 20 73 65 72 76 65 72 20 68 61 73 20 64 ;; server has d
2180: 69 65 64 2e 20 4e 4f 54 45 3a 20 74 68 69 73 20 ied. NOTE: this
2190: 69 73 20 6e 6f 74 20 61 20 63 68 65 61 70 20 63 is not a cheap c
21a0: 61 6c 6c 21 20 4e 65 65 64 20 62 65 74 74 65 72 all! Need better
21b0: 20 61 70 70 72 6f 61 63 68 2e 0a 20 20 20 20 20 approach..
21c0: 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 (set! *runremot
21d0: 65 2a 20 28 6d 61 6b 65 2d 72 65 6d 6f 74 65 29 e* (make-remote)
21e0: 29 0a 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d ). (remote-
21f0: 66 6f 72 63 65 2d 73 65 72 76 65 72 2d 73 65 74 force-server-set
2200: 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 63 6f 6d ! runremote (com
2210: 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 mon:force-server
2220: 3f 29 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 ?)). (mutex
2230: 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 -unlock! *rmt-mu
2240: 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 tex*). (deb
2250: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 ug:print-info 12
2260: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2270: 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 rt* "rmt:send-re
2280: 63 65 69 76 65 2c 20 63 61 73 65 20 20 36 22 29 ceive, case 6")
2290: 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 . (rmt:send
22a0: 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 -receive cmd rid
22b0: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
22c0: 75 6d 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 um: attemptnum))
22d0: 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 .. ;;DOT CAS
22e0: 45 37 20 5b 6c 61 62 65 6c 3d 22 68 6f 6d 65 68 E7 [label="homeh
22f0: 6f 73 74 5c 6e 77 72 69 74 65 22 5d 3b 0a 20 20 ost\nwrite"];.
2300: 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f ;;DOT MUTEXLO
2310: 43 4b 20 2d 3e 20 43 41 53 45 37 20 5b 6c 61 62 CK -> CASE7 [lab
2320: 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 el="server not r
2330: 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d equired,\non hom
2340: 65 68 6f 73 74 2c 5c 6e 61 20 77 72 69 74 65 2c ehost,\na write,
2350: 5c 6e 68 61 76 65 20 61 20 73 65 72 76 65 72 22 \nhave a server"
2360: 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 ]; {rank=same "c
2370: 61 73 65 20 37 22 20 43 41 53 45 37 7d 3b 0a 20 ase 7" CASE7};.
2380: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 37 20 ;;DOT CASE7
2390: 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 -> "rmt:open-qry
23a0: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b -close-locally";
23b0: 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 . ;; on home
23c0: 68 6f 73 74 20 61 6e 64 20 74 68 69 73 20 69 73 host and this is
23d0: 20 61 20 77 72 69 74 65 2c 20 77 65 20 61 6c 72 a write, we alr
23e0: 65 61 64 79 20 68 61 76 65 20 61 20 73 65 72 76 eady have a serv
23f0: 65 72 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e er. ((and (n
2400: 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 ot (remote-force
2410: 2d 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 -server runremot
2420: 65 29 29 20 20 20 20 20 3b 3b 20 68 6f 6e 6f 72 e)) ;; honor
2430: 20 66 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 forced use of s
2440: 65 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 erver, i.e. serv
2450: 65 72 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a er NOT required.
2460: 09 20 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 . (cdr (remote
2470: 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 -hh-dat runremot
2480: 65 29 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b e)) ;;
2490: 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 20 20 on homehost.
24a0: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 (not (me
24b0: 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 mber cmd api:rea
24c0: 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 d-only-queries))
24d0: 20 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 77 ;; this is a w
24e0: 72 69 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 rite.
24f0: 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 (remote-server-u
2500: 72 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 rl runremote))
2510: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 68 61 76 ;; hav
2520: 65 20 61 20 73 65 72 76 65 72 0a 20 20 20 20 20 e a server.
2530: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
2540: 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 *rmt-mutex*).
2550: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2560: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
2570: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
2580: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
2590: 73 65 20 20 34 2e 31 22 29 0a 20 20 20 20 20 20 se 4.1").
25a0: 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c (rmt:open-qry-cl
25b0: 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 ose-locally cmd
25c0: 30 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 0 params))..
25d0: 20 3b 3b 44 4f 54 20 43 41 53 45 38 20 5b 6c 61 ;;DOT CASE8 [la
25e0: 62 65 6c 3d 22 66 6f 72 63 65 5c 6e 73 65 72 76 bel="force\nserv
25f0: 65 72 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 er"];. ;;DOT
2600: 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 MUTEXLOCK -> CA
2610: 53 45 38 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 SE8 [label="serv
2620: 65 72 20 6e 6f 74 20 72 65 71 75 69 72 65 64 2c er not required,
2630: 5c 6e 68 61 76 65 20 68 6f 6d 65 68 6f 73 74 20 \nhave homehost
2640: 69 6e 66 6f 2c 5c 6e 6e 6f 20 63 6f 6e 6e 65 63 info,\nno connec
2650: 74 69 6f 6e 20 79 65 74 2c 5c 6e 6e 6f 74 20 61 tion yet,\nnot a
2660: 20 72 65 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 read-only query
2670: 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 "]; {rank=same "
2680: 63 61 73 65 20 38 22 20 43 41 53 45 38 7d 3b 0a case 8" CASE8};.
2690: 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 38 ;;DOT CASE8
26a0: 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 -> "rmt:open-qr
26b0: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 y-close-locally"
26c0: 3b 0a 20 20 20 20 20 3b 3b 20 20 6f 6e 20 68 6f ;. ;; on ho
26d0: 6d 65 68 6f 73 74 2c 20 6e 6f 20 73 65 72 76 65 mehost, no serve
26e0: 72 20 63 6f 6e 74 61 63 74 20 6d 61 64 65 20 61 r contact made a
26f0: 6e 64 20 74 68 69 73 20 69 73 20 61 20 77 72 69 nd this is a wri
2700: 74 65 2c 20 70 61 73 73 69 76 65 6c 79 20 73 74 te, passively st
2710: 61 72 74 20 61 20 73 65 72 76 65 72 20 0a 20 20 art a server .
2720: 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 72 ((and (not (r
2730: 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 emote-force-serv
2740: 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 er runremote))
2750: 20 20 20 3b 3b 20 68 6f 6e 6f 72 20 66 6f 72 63 ;; honor forc
2760: 65 64 20 75 73 65 20 6f 66 20 73 65 72 76 65 72 ed use of server
2770: 2c 20 69 2e 65 2e 20 73 65 72 76 65 72 20 4e 4f , i.e. server NO
2780: 54 20 72 65 71 75 69 72 65 64 0a 09 20 20 20 28 T required.. (
2790: 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 cdr (remote-hh-d
27a0: 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 at runremote))
27b0: 20 20 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 ;; have
27c0: 20 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 homehost.
27d0: 20 20 20 20 20 28 6e 6f 74 20 28 72 65 6d 6f 74 (not (remot
27e0: 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e e-server-url run
27f0: 72 65 6d 6f 74 65 29 29 20 20 20 20 20 20 20 3b remote)) ;
2800: 3b 20 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 ; no connection
2810: 79 65 74 0a 09 20 20 20 28 6e 6f 74 20 28 6d 65 yet.. (not (me
2820: 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 mber cmd api:rea
2830: 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 d-only-queries))
2840: 29 20 3b 3b 20 6e 6f 74 20 61 20 72 65 61 64 2d ) ;; not a read-
2850: 6f 6e 6c 79 20 71 75 65 72 79 0a 20 20 20 20 20 only query.
2860: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2870: 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 12 *default-l
2880: 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 og-port* "rmt:se
2890: 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 nd-receive, case
28a0: 20 20 38 22 29 0a 20 20 20 20 20 20 28 6c 65 74 8"). (let
28b0: 20 28 28 73 65 72 76 65 72 2d 75 72 6c 20 20 28 ((server-url (
28c0: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
28d0: 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 running *toppath
28e0: 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 3a *))) ;; (server:
28f0: 72 65 61 64 2d 64 6f 74 73 65 72 76 65 72 2d 3e read-dotserver->
2900: 75 72 6c 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 url *toppath*)))
2910: 20 3b 3b 20 28 73 65 72 76 65 72 3a 63 68 65 63 ;; (server:chec
2920: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
2930: 70 70 61 74 68 2a 29 29 29 20 3b 3b 20 44 6f 20 ppath*))) ;; Do
2940: 4e 4f 54 20 77 61 6e 74 20 74 6f 20 72 75 6e 20 NOT want to run
2950: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
2960: 72 75 6e 6e 69 6e 67 20 2d 20 76 65 72 79 20 65 running - very e
2970: 78 70 65 6e 73 69 76 65 20 74 6f 20 64 6f 20 66 xpensive to do f
2980: 6f 72 20 65 76 65 72 79 20 77 72 69 74 65 20 63 or every write c
2990: 61 6c 6c 0a 09 28 69 66 20 73 65 72 76 65 72 2d all..(if server-
29a0: 75 72 6c 0a 09 20 20 20 20 28 72 65 6d 6f 74 65 url.. (remote
29b0: 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 21 -server-url-set!
29c0: 20 72 75 6e 72 65 6d 6f 74 65 20 73 65 72 76 65 runremote serve
29d0: 72 2d 75 72 6c 29 20 3b 3b 20 74 68 65 20 73 74 r-url) ;; the st
29e0: 72 69 6e 67 20 63 61 6e 20 62 65 20 63 6f 6e 73 ring can be cons
29f0: 75 6d 65 64 20 62 79 20 74 68 65 20 63 6c 69 65 umed by the clie
2a00: 6e 74 20 73 65 74 75 70 20 69 66 20 6e 65 65 64 nt setup if need
2a10: 65 64 0a 09 20 20 20 20 28 69 66 20 28 63 6f 6d ed.. (if (com
2a20: 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 mon:force-server
2a30: 3f 29 0a 09 09 28 73 65 72 76 65 72 3a 73 74 61 ?)...(server:sta
2a40: 72 74 2d 61 6e 64 2d 77 61 69 74 20 2a 74 6f 70 rt-and-wait *top
2a50: 70 61 74 68 2a 29 0a 09 09 28 73 65 72 76 65 72 path*)...(server
2a60: 3a 6b 69 6e 64 2d 72 75 6e 20 2a 74 6f 70 70 61 :kind-run *toppa
2a70: 74 68 2a 29 29 29 29 0a 20 20 20 20 20 20 28 72 th*)))). (r
2a80: 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 emote-force-serv
2a90: 65 72 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 er-set! runremot
2aa0: 65 20 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d e (common:force-
2ab0: 73 65 72 76 65 72 3f 29 29 0a 20 20 20 20 20 20 server?)).
2ac0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
2ad0: 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 rmt-mutex*).
2ae0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
2af0: 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d nfo 12 *default-
2b00: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 log-port* "rmt:s
2b10: 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 end-receive, cas
2b20: 65 20 20 38 2e 31 22 29 0a 20 20 20 20 20 20 28 e 8.1"). (
2b30: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
2b40: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 se-locally cmd 0
2b50: 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 params))..
2b60: 3b 3b 44 4f 54 20 43 41 53 45 39 20 5b 6c 61 62 ;;DOT CASE9 [lab
2b70: 65 6c 3d 22 66 6f 72 63 65 20 73 65 72 76 65 72 el="force server
2b80: 5c 6e 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 \nnot on homehos
2b90: 74 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 t"];. ;;DOT
2ba0: 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 MUTEXLOCK -> CAS
2bb0: 45 39 20 5b 6c 61 62 65 6c 3d 22 6e 6f 20 63 6f E9 [label="no co
2bc0: 6e 6e 65 63 74 69 6f 6e 5c 6e 61 6e 64 20 65 69 nnection\nand ei
2bd0: 74 68 65 72 20 72 65 71 75 69 72 65 20 73 65 72 ther require ser
2be0: 76 65 72 5c 6e 6f 72 20 6e 6f 74 20 6f 6e 20 68 ver\nor not on h
2bf0: 6f 6d 65 68 6f 73 74 22 5d 3b 20 7b 72 61 6e 6b omehost"]; {rank
2c00: 3d 73 61 6d 65 20 22 63 61 73 65 20 39 22 20 43 =same "case 9" C
2c10: 41 53 45 39 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f ASE9};. ;;DO
2c20: 54 20 43 41 53 45 39 20 2d 3e 20 22 73 74 61 72 T CASE9 -> "star
2c30: 74 5c 6e 73 65 72 76 65 72 22 20 2d 3e 20 22 72 t\nserver" -> "r
2c40: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 22 mt:send-receive"
2c50: 3b 0a 20 20 20 20 20 28 28 6f 72 20 28 61 6e 64 ;. ((or (and
2c60: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
2c70: 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 erver runremote)
2c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
2c90: 20 77 65 20 61 72 65 20 66 6f 72 63 69 6e 67 20 we are forcing
2ca0: 61 20 73 65 72 76 65 72 20 61 6e 64 20 64 6f 6e a server and don
2cb0: 27 74 20 79 65 74 20 68 61 76 65 20 61 20 63 6f 't yet have a co
2cc0: 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 6f 6e 65 0a nnection to one.
2cd0: 09 20 20 20 20 20 20 20 28 6e 6f 74 20 28 72 65 . (not (re
2ce0: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e mote-conndat run
2cf0: 72 65 6d 6f 74 65 29 29 29 0a 09 20 20 28 61 6e remote))).. (an
2d00: 64 20 28 6e 6f 74 20 28 63 64 72 20 28 72 65 6d d (not (cdr (rem
2d10: 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 ote-hh-dat runre
2d20: 6d 6f 74 65 29 29 29 20 20 20 20 20 20 20 20 3b mote))) ;
2d30: 3b 20 6e 6f 74 20 6f 6e 20 61 20 68 6f 6d 65 68 ; not on a homeh
2d40: 6f 73 74 20 0a 09 20 20 20 20 20 20 20 28 6e 6f ost .. (no
2d50: 74 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 t (remote-connda
2d60: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 t runremote))))
2d70: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 61 6e 64 ;; and
2d80: 20 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 no connection.
2d90: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2da0: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
2db0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
2dc0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
2dd0: 63 61 73 65 20 39 2c 20 68 68 2d 64 61 74 3a 20 case 9, hh-dat:
2de0: 22 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 " (remote-hh-dat
2df0: 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 20 63 6f runremote) " co
2e00: 6e 6e 64 61 74 3a 20 22 20 28 72 65 6d 6f 74 65 nndat: " (remote
2e10: 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f -conndat runremo
2e20: 74 65 29 29 0a 20 20 20 20 20 20 28 6d 75 74 65 te)). (mute
2e30: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d x-unlock! *rmt-m
2e40: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 69 66 utex*). (if
2e50: 20 28 6e 6f 74 20 28 73 65 72 76 65 72 3a 63 68 (not (server:ch
2e60: 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a eck-if-running *
2e70: 74 6f 70 70 61 74 68 2a 29 29 20 3b 3b 20 77 68 toppath*)) ;; wh
2e80: 6f 20 6b 6e 6f 77 73 2c 20 6d 61 79 62 65 20 6f o knows, maybe o
2e90: 6e 65 20 68 61 73 20 73 74 61 72 74 65 64 20 75 ne has started u
2ea0: 70 3f 0a 09 20 20 28 73 65 72 76 65 72 3a 73 74 p?.. (server:st
2eb0: 61 72 74 2d 61 6e 64 2d 77 61 69 74 20 2a 74 6f art-and-wait *to
2ec0: 70 70 61 74 68 2a 29 29 0a 20 20 20 20 20 20 28 ppath*)). (
2ed0: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 remote-conndat-s
2ee0: 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 72 et! runremote (r
2ef0: 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f mt:get-connectio
2f00: 6e 2d 69 6e 66 6f 20 2a 74 6f 70 70 61 74 68 2a n-info *toppath*
2f10: 29 29 20 3b 3b 20 63 61 6c 6c 73 20 63 6c 69 65 )) ;; calls clie
2f20: 6e 74 3a 73 65 74 75 70 20 77 68 69 63 68 20 63 nt:setup which c
2f30: 61 6c 6c 73 20 63 6c 69 65 6e 74 3a 73 65 74 75 alls client:setu
2f40: 70 2d 68 74 74 70 0a 20 20 20 20 20 20 28 72 6d p-http. (rm
2f50: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 t:send-receive c
2f60: 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 md rid params at
2f70: 74 65 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 temptnum: attemp
2f80: 74 6e 75 6d 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 tnum)) ;; TODO:
2f90: 61 64 64 20 62 61 63 6b 2d 6f 66 66 20 74 69 6d add back-off tim
2fa0: 65 6f 75 74 20 61 73 0a 0a 20 20 20 20 20 3b 3b eout as.. ;;
2fb0: 44 4f 54 20 43 41 53 45 31 30 20 5b 6c 61 62 65 DOT CASE10 [labe
2fc0: 6c 3d 22 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 5d l="on homehost"]
2fd0: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 ;. ;;DOT MUT
2fe0: 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 31 30 EXLOCK -> CASE10
2ff0: 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 20 [label="server
3000: 6e 6f 74 20 72 65 71 75 69 72 65 64 2c 5c 6e 6f not required,\no
3010: 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b 20 7b 72 n homehost"]; {r
3020: 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 31 ank=same "case 1
3030: 30 22 20 43 41 53 45 31 30 7d 3b 0a 20 20 20 20 0" CASE10};.
3040: 20 3b 3b 44 4f 54 20 43 41 53 45 31 30 20 2d 3e ;;DOT CASE10 ->
3050: 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 "rmt:open-qry-c
3060: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 lose-locally";.
3070: 20 20 20 20 3b 3b 20 61 6c 6c 20 73 65 74 20 75 ;; all set u
3080: 70 20 69 66 20 67 65 74 20 74 68 69 73 20 66 61 p if get this fa
3090: 72 2c 20 64 69 73 70 61 74 63 68 20 74 68 65 20 r, dispatch the
30a0: 71 75 65 72 79 0a 20 20 20 20 20 28 28 61 6e 64 query. ((and
30b0: 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f (not (remote-fo
30c0: 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 rce-server runre
30d0: 6d 6f 74 65 29 29 0a 09 20 20 20 28 63 64 72 20 mote)).. (cdr
30e0: 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 (remote-hh-dat r
30f0: 75 6e 72 65 6d 6f 74 65 29 29 29 20 3b 3b 20 77 unremote))) ;; w
3100: 65 20 61 72 65 20 6f 6e 20 68 6f 6d 65 68 6f 73 e are on homehos
3110: 74 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 t. (mutex-u
3120: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
3130: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
3140: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
3150: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3160: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
3170: 69 76 65 2c 20 63 61 73 65 20 31 30 22 29 0a 20 ive, case 10").
3180: 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 (rmt:open-q
3190: 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 ry-close-locally
31a0: 20 63 6d 64 20 28 69 66 20 72 69 64 20 72 69 64 cmd (if rid rid
31b0: 20 30 29 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 0) params))..
31c0: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 31 31 20 ;;DOT CASE11
31d0: 5b 6c 61 62 65 6c 3d 22 73 65 6e 64 5f 72 65 63 [label="send_rec
31e0: 65 69 76 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 eive"];. ;;D
31f0: 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 OT MUTEXLOCK ->
3200: 43 41 53 45 31 31 20 5b 6c 61 62 65 6c 3d 22 65 CASE11 [label="e
3210: 6c 73 65 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d lse"]; {rank=sam
3220: 65 20 22 63 61 73 65 20 31 31 22 20 43 41 53 45 e "case 11" CASE
3230: 31 31 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 11};. ;;DOT
3240: 43 41 53 45 31 31 20 2d 3e 20 22 72 6d 74 3a 73 CASE11 -> "rmt:s
3250: 65 6e 64 2d 72 65 63 65 69 76 65 22 20 5b 6c 61 end-receive" [la
3260: 62 65 6c 3d 22 63 61 6c 6c 20 66 61 69 6c 65 64 bel="call failed
3270: 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 "];. ;;DOT C
3280: 41 53 45 31 31 20 2d 3e 20 22 52 45 53 55 4c 54 ASE11 -> "RESULT
3290: 22 20 5b 6c 61 62 65 6c 3d 22 63 61 6c 6c 20 73 " [label="call s
32a0: 75 63 63 65 65 64 65 64 22 5d 3b 0a 20 20 20 20 ucceeded"];.
32b0: 20 3b 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 ;; not on homeh
32c0: 6f 73 74 2c 20 64 6f 20 73 65 72 76 65 72 20 71 ost, do server q
32d0: 75 65 72 79 0a 20 20 20 20 20 28 65 6c 73 65 0a uery. (else.
32e0: 20 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d ;; (mutex-
32f0: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
3300: 65 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 ex*). (debu
3310: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 g:print-info 12
3320: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3330: 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 t* "rmt:send-rec
3340: 65 69 76 65 2c 20 63 61 73 65 20 20 39 22 29 0a eive, case 9").
3350: 20 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d ;; (mutex-
3360: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
3370: 2a 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 *). (let* (
3380: 28 63 6f 6e 6e 69 6e 66 6f 20 28 72 65 6d 6f 74 (conninfo (remot
3390: 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d e-conndat runrem
33a0: 6f 74 65 29 29 0a 09 20 20 20 20 20 28 64 61 74 ote)).. (dat
33b0: 20 20 20 20 20 20 28 63 61 73 65 20 28 72 65 6d (case (rem
33c0: 6f 74 65 2d 74 72 61 6e 73 70 6f 72 74 20 72 75 ote-transport ru
33d0: 6e 72 65 6d 6f 74 65 29 0a 09 09 09 20 28 28 68 nremote).... ((h
33e0: 74 74 70 29 20 28 63 6f 6e 64 69 74 69 6f 6e 2d ttp) (condition-
33f0: 63 61 73 65 20 3b 3b 20 68 61 6e 64 6c 69 6e 67 case ;; handling
3400: 20 68 65 72 65 20 68 61 73 20 63 61 75 73 65 64 here has caused
3410: 20 61 20 6c 6f 74 20 6f 66 20 70 72 6f 62 6c 65 a lot of proble
3420: 6d 73 2e 20 48 6f 77 65 76 65 72 20 69 74 20 69 ms. However it i
3430: 73 20 6e 65 65 64 65 64 20 74 6f 20 64 65 61 6c s needed to deal
3440: 20 77 69 74 68 20 61 74 74 65 6d 74 70 65 64 20 with attemtped
3450: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 74 6f communication to
3460: 20 73 65 72 76 65 72 73 20 74 68 61 74 20 68 61 servers that ha
3470: 76 65 20 67 6f 6e 65 20 61 77 61 79 0a 20 20 20 ve gone away.
3480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
34a0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
34b0: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
34c0: 65 63 65 69 76 65 20 30 20 63 6f 6e 6e 69 6e 66 eceive 0 conninf
34d0: 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 o cmd params).
34e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
34f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3500: 28 28 63 6f 6d 6d 66 61 69 6c 29 28 76 65 63 74 ((commfail)(vect
3510: 6f 72 20 23 66 20 22 63 6f 6d 6d 75 6e 69 63 61 or #f "communica
3520: 74 69 6f 6e 73 20 66 61 69 6c 22 29 29 0a 20 20 tions fail")).
3530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3550: 28 28 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 ((exn)(vector #f
3560: 20 22 6f 74 68 65 72 20 66 61 69 6c 22 20 28 70 "other fail" (p
3570: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 rint-call-chain)
3580: 29 29 29 29 0a 09 09 09 20 28 65 6c 73 65 0a 09 )))).... (else..
3590: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
35a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
35b0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 74 72 port* "ERROR: tr
35c0: 61 6e 73 70 6f 72 74 20 22 20 28 72 65 6d 6f 74 ansport " (remot
35d0: 65 2d 74 72 61 6e 73 70 6f 72 74 20 72 75 6e 72 e-transport runr
35e0: 65 6d 6f 74 65 29 20 22 20 6e 6f 74 20 73 75 70 emote) " not sup
35f0: 70 6f 72 74 65 64 22 29 0a 09 09 09 20 20 28 65 ported").... (e
3600: 78 69 74 29 29 29 29 0a 09 20 20 20 20 20 28 73 xit)))).. (s
3610: 75 63 63 65 73 73 20 20 28 69 66 20 28 76 65 63 uccess (if (vec
3620: 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 74 6f tor? dat) (vecto
3630: 72 2d 72 65 66 20 64 61 74 20 30 29 20 23 66 29 r-ref dat 0) #f)
3640: 29 0a 09 20 20 20 20 20 28 72 65 73 20 20 20 20 ).. (res
3650: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 64 (if (vector? d
3660: 61 74 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 at) (vector-ref
3670: 64 61 74 20 31 29 20 23 66 29 29 29 0a 09 28 69 dat 1) #f)))..(i
3680: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
3690: 63 6f 6e 6e 69 6e 66 6f 29 20 28 3c 20 35 20 28 conninfo) (< 5 (
36a0: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 63 6f vector-length co
36b0: 6e 6e 69 6e 66 6f 29 29 29 0a 20 20 20 20 20 20 nninfo))).
36c0: 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e (http-tran
36d0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
36e0: 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 -update-last-acc
36f0: 65 73 73 20 63 6f 6e 6e 69 6e 66 6f 29 20 3b 3b ess conninfo) ;;
3700: 20 72 65 66 72 65 73 68 20 61 63 63 65 73 73 20 refresh access
3710: 74 69 6d 65 0a 09 20 20 20 20 28 62 65 67 69 6e time.. (begin
3720: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3730: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3740: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3750: 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 20 6e "INFO: Should n
3760: 6f 74 20 67 65 74 20 68 65 72 65 21 20 63 6f 6e ot get here! con
3770: 6e 69 6e 66 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f ninfo=" conninfo
3780: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3790: 28 73 65 74 21 20 63 6f 6e 6e 69 6e 66 6f 20 23 (set! conninfo #
37a0: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
37b0: 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 (remote-conndat
37c0: 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 -set! *runremote
37d0: 2a 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 * #f).
37e0: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
37f0: 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
3800: 74 69 6f 6e 73 20 20 61 72 65 61 2d 64 61 74 3a tions area-dat:
3810: 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 0a 09 3b runremote)))..;
3820: 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 ; (mutex-unlock!
3830: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 *rmt-mutex*).
3840: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3850: 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 nt-info 13 *defa
3860: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
3870: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c mt:send-receive,
3880: 20 63 61 73 65 20 20 39 2e 20 63 6f 6e 6e 69 6e case 9. connin
3890: 66 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f 20 22 20 fo=" conninfo "
38a0: 64 61 74 3d 22 20 64 61 74 20 22 20 72 75 6e 72 dat=" dat " runr
38b0: 65 6d 6f 74 65 20 3d 20 22 20 72 75 6e 72 65 6d emote = " runrem
38c0: 6f 74 65 29 0a 09 28 6d 75 74 65 78 2d 75 6e 6c ote)..(mutex-unl
38d0: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
38e0: 29 0a 09 28 69 66 20 73 75 63 63 65 73 73 20 3b )..(if success ;
38f0: 3b 20 73 75 63 63 65 73 73 20 6f 6e 6c 79 20 74 ; success only t
3900: 65 6c 6c 73 20 75 73 20 74 68 61 74 20 74 68 65 ells us that the
3910: 20 74 72 61 6e 73 70 6f 72 74 20 77 61 73 20 73 transport was s
3920: 75 63 63 65 73 73 66 75 6c 2c 20 68 61 76 65 20 uccessful, have
3930: 74 6f 20 65 78 61 6d 69 6e 65 20 74 68 65 20 64 to examine the d
3940: 61 74 61 20 74 6f 20 73 65 65 20 69 66 20 74 68 ata to see if th
3950: 65 72 65 20 77 61 73 20 61 20 64 65 74 65 63 74 ere was a detect
3960: 65 64 20 69 73 73 75 65 20 61 74 20 74 68 65 20 ed issue at the
3970: 6f 74 68 65 72 20 65 6e 64 0a 09 20 20 20 20 28 other end.. (
3980: 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f if (and (vector?
3990: 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 65 71 res)... (eq
39a0: 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 ? (vector-length
39b0: 20 72 65 73 29 20 32 29 0a 09 09 20 20 20 20 20 res) 2)...
39c0: 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 (eq? (vector-ref
39d0: 20 72 65 73 20 31 29 20 27 6f 76 65 72 6c 6f 61 res 1) 'overloa
39e0: 64 65 64 29 29 20 3b 3b 20 73 69 6e 63 65 20 77 ded)) ;; since w
39f0: 65 20 61 72 65 20 6c 6f 6f 6b 69 6e 67 20 61 74 e are looking at
3a00: 20 74 68 65 20 64 61 74 61 20 74 6f 20 63 61 72 the data to car
3a10: 72 79 20 74 68 65 20 65 72 72 6f 72 20 77 65 27 ry the error we'
3a20: 6c 6c 20 75 73 65 20 61 20 66 61 69 72 6c 79 20 ll use a fairly
3a30: 6f 62 74 75 73 65 20 63 6f 6d 62 6f 20 74 6f 20 obtuse combo to
3a40: 6d 69 6e 69 6d 69 73 65 20 74 68 65 20 63 68 61 minimise the cha
3a50: 6e 63 65 73 20 6f 66 20 73 6f 6d 65 20 73 6f 72 nces of some sor
3a60: 74 20 6f 66 20 63 6f 6c 6c 69 73 69 6f 6e 2e 0a t of collision..
3a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a80: 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 63 ;; this is the c
3a90: 61 73 65 20 77 68 65 72 65 20 74 68 65 20 72 65 ase where the re
3aa0: 74 75 72 6e 65 64 20 64 61 74 61 20 69 73 20 62 turned data is b
3ab0: 61 64 20 6f 72 20 74 68 65 20 73 65 72 76 65 72 ad or the server
3ac0: 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 64 20 61 is overloaded a
3ad0: 6e 64 20 77 65 20 77 61 6e 74 0a 20 20 20 20 20 nd we want.
3ae0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 6f ;; to
3af0: 20 65 61 73 65 20 6f 66 66 20 74 68 65 20 71 75 ease off the qu
3b00: 65 72 69 65 73 0a 09 09 28 6c 65 74 20 28 28 77 eries...(let ((w
3b10: 61 69 74 2d 64 65 6c 61 79 20 28 2b 20 61 74 74 ait-delay (+ att
3b20: 65 6d 70 74 6e 75 6d 20 28 2a 20 61 74 74 65 6d emptnum (* attem
3b30: 70 74 6e 75 6d 20 31 30 29 29 29 29 0a 09 09 20 ptnum 10))))...
3b40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3b50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3b60: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 t* "WARNING: ser
3b70: 76 65 72 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 ver is overloade
3b80: 64 2e 20 44 65 6c 61 79 69 6e 67 20 22 20 77 61 d. Delaying " wa
3b90: 69 74 2d 64 65 6c 61 79 20 22 20 73 65 63 6f 6e it-delay " secon
3ba0: 64 73 20 61 6e 64 20 74 72 79 69 6e 67 20 63 61 ds and trying ca
3bb0: 6c 6c 20 61 67 61 69 6e 2e 22 29 0a 09 09 20 20 ll again.")...
3bc0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 6d (mutex-lock! *rm
3bd0: 74 2d 6d 75 74 65 78 2a 29 0a 09 09 20 20 28 68 t-mutex*)... (h
3be0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
3bf0: 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 ose-connections
3c00: 61 72 65 61 2d 64 61 74 3a 20 72 75 6e 72 65 6d area-dat: runrem
3c10: 6f 74 65 29 0a 09 09 20 20 28 73 65 74 21 20 2a ote)... (set! *
3c20: 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 20 3b runremote* #f) ;
3c30: 3b 20 66 6f 72 63 65 20 73 74 61 72 74 69 6e 67 ; force starting
3c40: 20 6f 76 65 72 0a 09 09 20 20 28 6d 75 74 65 78 over... (mutex
3c50: 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 -unlock! *rmt-mu
3c60: 74 65 78 2a 29 0a 09 09 20 20 28 74 68 72 65 61 tex*)... (threa
3c70: 64 2d 73 6c 65 65 70 21 20 77 61 69 74 2d 64 65 d-sleep! wait-de
3c80: 6c 61 79 29 0a 09 09 20 20 28 72 6d 74 3a 73 65 lay)... (rmt:se
3c90: 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 nd-receive cmd r
3ca0: 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 id params attemp
3cb0: 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 6d 70 74 tnum: (+ attempt
3cc0: 6e 75 6d 20 31 29 29 29 0a 09 09 72 65 73 29 20 num 1)))...res)
3cd0: 3b 3b 20 41 6c 6c 20 67 6f 6f 64 2c 20 72 65 74 ;; All good, ret
3ce0: 75 72 6e 20 72 65 73 0a 09 20 20 20 20 28 62 65 urn res.. (be
3cf0: 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
3d00: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3d10: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
3d20: 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 RNING: communica
3d30: 74 69 6f 6e 20 66 61 69 6c 65 64 2e 20 54 72 79 tion failed. Try
3d40: 69 6e 67 20 61 67 61 69 6e 2c 20 74 72 79 20 6e ing again, try n
3d50: 75 6d 3a 20 22 20 61 74 74 65 6d 70 74 6e 75 6d um: " attemptnum
3d60: 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d ).. (mutex-
3d70: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
3d80: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
3d90: 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 (remote-conndat
3da0: 2d 73 65 74 21 20 20 20 20 72 75 6e 72 65 6d 6f -set! runremo
3db0: 74 65 20 23 66 29 0a 09 20 20 20 20 20 20 28 68 te #f).. (h
3dc0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
3dd0: 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 ose-connections
3de0: 61 72 65 61 2d 64 61 74 3a 20 72 75 6e 72 65 6d area-dat: runrem
3df0: 6f 74 65 29 0a 09 20 20 20 20 20 20 28 72 65 6d ote).. (rem
3e00: 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 ote-server-url-s
3e10: 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 66 et! runremote #f
3e20: 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d ).. (mutex-
3e30: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
3e40: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
3e50: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3e60: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
3e70: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
3e80: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
3e90: 73 65 20 20 39 2e 31 22 29 0a 09 20 20 20 20 20 se 9.1")..
3ea0: 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 28 73 65 ;; (if (not (se
3eb0: 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 rver:check-if-ru
3ec0: 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 nning *toppath*)
3ed0: 29 0a 09 20 20 20 20 20 20 3b 3b 20 09 20 20 28 ).. ;; . (
3ee0: 73 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 server:start-and
3ef0: 2d 77 61 69 74 20 2a 74 6f 70 70 61 74 68 2a 29 -wait *toppath*)
3f00: 29 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 73 65 ).. (rmt:se
3f10: 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 nd-receive cmd r
3f20: 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 id params attemp
3f30: 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 6d 70 74 tnum: (+ attempt
3f40: 6e 75 6d 20 31 29 29 29 29 29 29 29 29 29 0a 0a num 1)))))))))..
3f50: 20 20 20 20 3b 3b 44 4f 54 20 7d 0a 20 20 20 20 ;;DOT }.
3f60: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 .;; (define (rmt
3f70: 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 74 73 :update-db-stats
3f80: 20 72 75 6e 2d 69 64 20 72 61 77 63 6d 64 20 70 run-id rawcmd p
3f90: 61 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a arams duration).
3fa0: 3b 3b 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b ;; (mutex-lock
3fb0: 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 ! *db-stats-mute
3fc0: 78 2a 29 0a 3b 3b 20 20 20 28 68 61 6e 64 6c 65 x*).;; (handle
3fd0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 -exceptions.;;
3fe0: 20 20 65 78 6e 0a 3b 3b 20 20 20 20 28 62 65 67 exn.;; (beg
3ff0: 69 6e 0a 3b 3b 20 20 20 20 20 20 28 64 65 62 75 in.;; (debu
4000: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
4010: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
4020: 52 4e 49 4e 47 3a 20 73 74 61 74 73 20 63 6f 6c RNING: stats col
4030: 6c 65 63 74 69 6f 6e 20 66 61 69 6c 65 64 20 69 lection failed i
4040: 6e 20 75 70 64 61 74 65 2d 64 62 2d 73 74 61 74 n update-db-stat
4050: 73 22 29 0a 3b 3b 20 20 20 20 20 20 28 64 65 62 s").;; (deb
4060: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
4070: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
4080: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
4090: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
40a0: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
40b0: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 3b 3b essage) exn)).;;
40c0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 65 78 (print "ex
40d0: 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e n=" (condition->
40e0: 6c 69 73 74 20 65 78 6e 29 29 0a 3b 3b 20 20 20 list exn)).;;
40f0: 20 20 20 23 66 29 20 3b 3b 20 69 66 20 74 68 69 #f) ;; if thi
4100: 73 20 66 61 69 6c 73 20 77 65 20 64 6f 6e 27 74 s fails we don't
4110: 20 63 61 72 65 2c 20 69 74 20 69 73 20 6a 75 73 care, it is jus
4120: 74 20 73 74 61 74 73 0a 3b 3b 20 20 20 20 28 6c t stats.;; (l
4130: 65 74 2a 20 28 28 63 6d 64 20 20 20 20 20 20 28 et* ((cmd (
4140: 63 6f 6e 63 20 22 72 75 6e 2d 69 64 3d 22 20 72 conc "run-id=" r
4150: 75 6e 2d 69 64 20 22 20 22 20 28 69 66 20 28 65 un-id " " (if (e
4160: 71 3f 20 72 61 77 63 6d 64 20 27 67 65 6e 65 72 q? rawcmd 'gener
4170: 61 6c 2d 63 61 6c 6c 29 20 28 63 61 72 20 70 61 al-call) (car pa
4180: 72 61 6d 73 29 20 72 61 77 63 6d 64 29 29 29 0a rams) rawcmd))).
4190: 3b 3b 20 09 20 20 28 73 74 61 74 2d 76 65 63 20 ;; . (stat-vec
41a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
41b0: 64 65 66 61 75 6c 74 20 2a 64 62 2d 73 74 61 74 default *db-stat
41c0: 73 2a 20 63 6d 64 20 23 66 29 29 29 0a 3b 3b 20 s* cmd #f))).;;
41d0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 76 (if (not (v
41e0: 65 63 74 6f 72 3f 20 73 74 61 74 2d 76 65 63 29 ector? stat-vec)
41f0: 29 0a 3b 3b 20 09 20 28 6c 65 74 20 28 28 6e 65 ).;; . (let ((ne
4200: 77 76 65 63 20 28 76 65 63 74 6f 72 20 30 20 30 wvec (vector 0 0
4210: 29 29 29 0a 3b 3b 20 09 20 20 20 28 68 61 73 68 ))).;; . (hash
4220: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 62 2d -table-set! *db-
4230: 73 74 61 74 73 2a 20 63 6d 64 20 6e 65 77 76 65 stats* cmd newve
4240: 63 29 0a 3b 3b 20 09 20 20 20 28 73 65 74 21 20 c).;; . (set!
4250: 73 74 61 74 2d 76 65 63 20 6e 65 77 76 65 63 29 stat-vec newvec)
4260: 29 29 0a 3b 3b 20 20 20 20 20 20 28 76 65 63 74 )).;; (vect
4270: 6f 72 2d 73 65 74 21 20 73 74 61 74 2d 76 65 63 or-set! stat-vec
4280: 20 30 20 28 2b 20 28 76 65 63 74 6f 72 2d 72 65 0 (+ (vector-re
4290: 66 20 73 74 61 74 2d 76 65 63 20 30 29 20 31 29 f stat-vec 0) 1)
42a0: 29 0a 3b 3b 20 20 20 20 20 20 28 76 65 63 74 6f ).;; (vecto
42b0: 72 2d 73 65 74 21 20 73 74 61 74 2d 76 65 63 20 r-set! stat-vec
42c0: 31 20 28 2b 20 28 76 65 63 74 6f 72 2d 72 65 66 1 (+ (vector-ref
42d0: 20 73 74 61 74 2d 76 65 63 20 31 29 20 64 75 72 stat-vec 1) dur
42e0: 61 74 69 6f 6e 29 29 29 29 0a 3b 3b 20 20 20 28 ation)))).;; (
42f0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
4300: 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 29 b-stats-mutex*))
4310: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 70 ..(define (rmt:p
4320: 72 69 6e 74 2d 64 62 2d 73 74 61 74 73 29 0a 20 rint-db-stats).
4330: 20 28 6c 65 74 20 28 28 66 6d 74 73 74 72 20 22 (let ((fmtstr "
4340: 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 7e 32 30 2c ~40a~7-d~9-d~20,
4350: 32 2d 66 22 29 29 20 3b 3b 20 22 7e 32 30 2c 32 2-f")) ;; "~20,2
4360: 2d 66 22 0a 20 20 20 20 28 64 65 62 75 67 3a 70 -f". (debug:p
4370: 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c 74 rint 18 *default
4380: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 42 20 53 -log-port* "DB S
4390: 74 61 74 73 5c 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 29 tats\n========")
43a0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
43b0: 74 20 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f t 18 *default-lo
43c0: 67 2d 70 6f 72 74 2a 20 28 66 6f 72 6d 61 74 20 g-port* (format
43d0: 23 66 20 22 7e 34 30 61 7e 38 61 7e 31 30 61 7e #f "~40a~8a~10a~
43e0: 31 30 61 22 20 22 43 6d 64 22 20 22 43 6f 75 6e 10a" "Cmd" "Coun
43f0: 74 22 20 22 54 6f 74 54 69 6d 65 22 20 22 41 76 t" "TotTime" "Av
4400: 67 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 g")). (for-ea
4410: 63 68 20 28 6c 61 6d 62 64 61 20 28 63 6d 64 29 ch (lambda (cmd)
4420: 0a 09 09 28 6c 65 74 20 28 28 63 6d 64 2d 64 61 ...(let ((cmd-da
4430: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
4440: 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 f *db-stats* cmd
4450: 29 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 )))... (debug:p
4460: 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c 74 rint 18 *default
4470: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 6d -log-port* (form
4480: 61 74 20 23 66 20 66 6d 74 73 74 72 20 63 6d 64 at #f fmtstr cmd
4490: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 (vector-ref cmd
44a0: 2d 64 61 74 20 30 29 20 28 76 65 63 74 6f 72 2d -dat 0) (vector-
44b0: 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 20 28 ref cmd-dat 1) (
44c0: 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d / (vector-ref cm
44d0: 64 2d 64 61 74 20 31 29 28 76 65 63 74 6f 72 2d d-dat 1)(vector-
44e0: 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 29 29 ref cmd-dat 0)))
44f0: 29 29 29 0a 09 20 20 20 20 20 20 28 73 6f 72 74 ))).. (sort
4500: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
4510: 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 0a 09 09 s *db-stats*)...
4520: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
4530: 29 0a 09 09 20 20 20 20 20 20 28 3e 20 28 76 65 )... (> (ve
4540: 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 2d 74 ctor-ref (hash-t
4550: 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 able-ref *db-sta
4560: 74 73 2a 20 61 29 20 30 29 0a 09 09 09 20 28 76 ts* a) 0).... (v
4570: 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 2d ector-ref (hash-
4580: 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 table-ref *db-st
4590: 61 74 73 2a 20 62 29 20 30 29 29 29 29 29 29 29 ats* b) 0)))))))
45a0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
45b0: 65 74 2d 6d 61 78 2d 71 75 65 72 79 2d 61 76 65 et-max-query-ave
45c0: 72 61 67 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 rage run-id). (
45d0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
45e0: 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 stats-mutex*).
45f0: 28 6c 65 74 2a 20 28 28 72 75 6e 6b 65 79 20 28 (let* ((runkey (
4600: 63 6f 6e 63 20 22 72 75 6e 2d 69 64 3d 22 20 72 conc "run-id=" r
4610: 75 6e 2d 69 64 20 22 20 22 29 29 0a 09 20 28 63 un-id " ")).. (c
4620: 6d 64 73 20 20 20 28 66 69 6c 74 65 72 20 28 6c mds (filter (l
4630: 61 6d 62 64 61 20 28 78 29 0a 09 09 09 20 20 20 ambda (x)....
4640: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
4650: 20 72 75 6e 6b 65 79 20 78 29 29 0a 09 09 09 20 runkey x))....
4660: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
4670: 20 2a 64 62 2d 73 74 61 74 73 2a 29 29 29 0a 09 *db-stats*)))..
4680: 20 28 72 65 73 20 20 20 20 28 69 66 20 28 6e 75 (res (if (nu
4690: 6c 6c 3f 20 63 6d 64 73 29 0a 09 09 20 20 20 20 ll? cmds)...
46a0: 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 0a (cons 'none 0).
46b0: 09 09 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 .. (let loop
46c0: 20 28 28 63 6d 64 20 28 63 61 72 20 63 6d 64 73 ((cmd (car cmds
46d0: 29 29 0a 09 09 09 09 28 74 61 6c 20 28 63 64 72 )).....(tal (cdr
46e0: 20 63 6d 64 73 29 29 0a 09 09 09 09 28 6d 61 78 cmds)).....(max
46f0: 2d 63 6d 64 20 28 63 61 72 20 63 6d 64 73 29 29 -cmd (car cmds))
4700: 0a 09 09 09 09 28 72 65 73 20 30 29 29 0a 09 09 .....(res 0))...
4710: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 (let* ((c
4720: 6d 64 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 md-dat (hash-tab
4730: 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 le-ref *db-stats
4740: 2a 20 63 6d 64 29 29 0a 09 09 09 20 20 20 20 20 * cmd))....
4750: 20 28 74 6f 74 20 20 20 20 20 28 76 65 63 74 6f (tot (vecto
4760: 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 r-ref cmd-dat 0)
4770: 29 0a 09 09 09 20 20 20 20 20 20 28 63 75 72 72 ).... (curr
4780: 61 76 67 20 28 2f 20 28 76 65 63 74 6f 72 2d 72 avg (/ (vector-r
4790: 65 66 20 63 6d 64 2d 64 61 74 20 31 29 20 28 76 ef cmd-dat 1) (v
47a0: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
47b0: 74 20 30 29 29 29 20 3b 3b 20 63 6f 75 6e 74 20 t 0))) ;; count
47c0: 69 73 20 6e 65 76 65 72 20 7a 65 72 6f 20 62 79 is never zero by
47d0: 20 63 6f 6e 73 74 72 75 63 74 69 6f 6e 0a 09 09 construction...
47e0: 09 20 20 20 20 20 20 28 63 75 72 72 6d 61 78 20 . (currmax
47f0: 28 6d 61 78 20 72 65 73 20 63 75 72 72 61 76 67 (max res curravg
4800: 29 29 0a 09 09 09 20 20 20 20 20 20 28 6e 65 77 )).... (new
4810: 6d 61 78 2d 63 6d 64 20 28 69 66 20 28 3e 20 63 max-cmd (if (> c
4820: 75 72 72 61 76 67 20 72 65 73 29 20 63 6d 64 20 urravg res) cmd
4830: 6d 61 78 2d 63 6d 64 29 29 29 0a 09 09 09 20 28 max-cmd))).... (
4840: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
4850: 09 09 20 20 20 20 20 28 69 66 20 28 3e 20 74 6f .. (if (> to
4860: 74 20 31 30 29 0a 09 09 09 09 20 28 63 6f 6e 73 t 10)..... (cons
4870: 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 72 newmax-cmd curr
4880: 6d 61 78 29 0a 09 09 09 09 20 28 63 6f 6e 73 20 max)..... (cons
4890: 27 6e 6f 6e 65 20 30 29 29 0a 09 09 09 20 20 20 'none 0))....
48a0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
48b0: 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 6d 61 )(cdr tal) newma
48c0: 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 29 29 29 x-cmd currmax)))
48d0: 29 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d )))). (mutex-
48e0: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 74 unlock! *db-stat
48f0: 73 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 s-mutex*). re
4900: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d s))..(define (rm
4910: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
4920: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 6e -locally cmd run
4930: 2d 69 64 20 70 61 72 61 6d 73 20 23 21 6b 65 79 -id params #!key
4940: 20 28 72 65 6d 72 65 74 72 69 65 73 20 35 29 29 (remretries 5))
4950: 0a 20 20 28 6c 65 74 2a 20 28 28 71 72 79 2d 69 . (let* ((qry-i
4960: 73 2d 77 72 69 74 65 20 20 20 28 6e 6f 74 20 28 s-write (not (
4970: 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 member cmd api:r
4980: 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 ead-only-queries
4990: 29 29 29 0a 09 20 28 64 62 2d 66 69 6c 65 2d 70 ))).. (db-file-p
49a0: 61 74 68 20 20 20 28 64 62 3a 64 62 66 69 6c 65 ath (db:dbfile
49b0: 2d 70 61 74 68 29 29 20 3b 3b 20 20 30 29 29 0a -path)) ;; 0)).
49c0: 09 20 28 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 . (dbstruct-loca
49d0: 6c 20 28 64 62 3a 73 65 74 75 70 20 23 74 29 29 l (db:setup #t))
49e0: 20 20 3b 3b 20 6d 61 6b 65 2d 64 62 72 3a 64 62 ;; make-dbr:db
49f0: 73 74 72 75 63 74 20 70 61 74 68 3a 20 20 64 62 struct path: db
4a00: 64 69 72 20 6c 6f 63 61 6c 3a 20 23 74 29 29 29 dir local: #t)))
4a10: 0a 09 20 28 72 65 61 64 2d 6f 6e 6c 79 20 20 20 .. (read-only
4a20: 20 20 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 (not (file-wr
4a30: 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 2d 66 ite-access? db-f
4a40: 69 6c 65 2d 70 61 74 68 29 29 29 0a 09 20 28 73 ile-path))).. (s
4a50: 74 61 72 74 20 20 20 20 20 20 20 20 20 20 28 63 tart (c
4a60: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
4a70: 6e 64 73 29 29 0a 09 20 28 72 65 73 64 61 74 20 nds)).. (resdat
4a80: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
4a90: 20 28 61 6e 64 20 72 65 61 64 2d 6f 6e 6c 79 20 (and read-only
4aa0: 71 72 79 2d 69 73 2d 77 72 69 74 65 29 29 0a 09 qry-is-write))..
4ab0: 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 76 20 .. (let ((v
4ac0: 28 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 (api:execute-req
4ad0: 75 65 73 74 73 20 64 62 73 74 72 75 63 74 2d 6c uests dbstruct-l
4ae0: 6f 63 61 6c 20 28 76 65 63 74 6f 72 20 28 73 79 ocal (vector (sy
4af0: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 63 6d 64 mbol->string cmd
4b00: 29 20 70 61 72 61 6d 73 29 29 29 29 0a 09 09 09 ) params))))....
4b10: 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 (handle-e
4b20: 78 63 65 70 74 69 6f 6e 73 20 3b 3b 20 74 68 65 xceptions ;; the
4b30: 72 65 20 68 61 73 20 62 65 65 6e 20 61 20 6c 6f re has been a lo
4b40: 6e 67 20 68 69 73 74 6f 72 79 20 6f 66 20 72 65 ng history of re
4b50: 63 65 69 76 69 6e 67 20 73 74 72 61 6e 67 65 20 ceiving strange
4b60: 65 72 72 6f 72 73 20 66 72 6f 6d 20 76 61 6c 75 errors from valu
4b70: 65 73 20 72 65 74 75 72 6e 65 64 20 62 79 20 74 es returned by t
4b80: 68 65 20 63 6c 69 65 6e 74 20 77 68 65 6e 20 74 he client when t
4b90: 68 69 6e 67 73 20 67 6f 20 77 72 6f 6e 67 2e 2e hings go wrong..
4ba0: 0a 09 09 09 09 65 78 6e 20 20 20 20 20 20 20 20 .....exn
4bb0: 20 20 20 20 20 20 20 3b 3b 20 20 54 68 69 73 20 ;; This
4bc0: 69 73 20 61 6e 20 61 74 74 65 6d 70 74 20 74 6f is an attempt to
4bd0: 20 64 65 74 65 63 74 20 74 68 61 74 20 73 69 74 detect that sit
4be0: 75 61 74 69 6f 6e 20 61 6e 64 20 72 65 63 6f 76 uation and recov
4bf0: 65 72 20 67 72 61 63 65 66 75 6c 6c 79 0a 09 09 er gracefully...
4c00: 09 09 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 ..(begin..... (
4c10: 64 65 62 75 67 3a 70 72 69 6e 74 30 20 2a 64 65 debug:print0 *de
4c20: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4c30: 22 45 52 52 4f 52 3a 20 62 61 64 20 64 61 74 61 "ERROR: bad data
4c40: 20 66 72 6f 6d 20 73 65 72 76 65 72 20 22 20 76 from server " v
4c50: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 20 28 " message: " (
4c60: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
4c70: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
4c80: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
4c90: 29 0a 09 09 09 09 20 20 28 76 65 63 74 6f 72 20 )..... (vector
4ca0: 23 74 20 27 28 29 29 29 20 3b 3b 20 73 68 6f 75 #t '())) ;; shou
4cb0: 6c 64 20 61 6c 77 61 79 73 20 67 65 74 20 61 20 ld always get a
4cc0: 76 65 63 74 6f 72 20 62 75 74 20 69 66 20 73 6f vector but if so
4cd0: 6d 65 74 68 69 6e 67 20 67 6f 65 73 20 77 72 6f mething goes wro
4ce0: 6e 67 20 72 65 74 75 72 6e 20 61 20 64 75 6d 6d ng return a dumm
4cf0: 79 0a 09 09 09 09 28 69 66 20 28 61 6e 64 20 28 y.....(if (and (
4d00: 76 65 63 74 6f 72 3f 20 76 29 0a 09 09 09 09 09 vector? v)......
4d10: 20 28 3e 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 (> (vector-leng
4d20: 74 68 20 76 29 20 31 29 29 0a 09 09 09 09 20 20 th v) 1)).....
4d30: 20 20 28 6c 65 74 20 28 28 6e 65 77 76 65 63 20 (let ((newvec
4d40: 28 76 65 63 74 6f 72 20 28 76 65 63 74 6f 72 2d (vector (vector-
4d50: 72 65 66 20 76 20 30 29 28 76 65 63 74 6f 72 2d ref v 0)(vector-
4d60: 72 65 66 20 76 20 31 29 29 29 29 0a 09 09 09 09 ref v 1)))).....
4d70: 20 20 20 20 20 20 6e 65 77 76 65 63 29 20 20 20 newvec)
4d80: 20 20 20 20 20 20 20 20 3b 3b 20 62 79 20 63 6f ;; by co
4d90: 70 79 69 6e 67 20 74 68 65 20 76 65 63 74 6f 72 pying the vector
4da0: 20 77 68 69 6c 65 20 69 6e 73 69 64 65 20 74 68 while inside th
4db0: 65 20 65 72 72 6f 72 20 68 61 6e 64 6c 65 72 20 e error handler
4dc0: 77 65 20 73 68 6f 75 6c 64 20 66 6f 72 63 65 20 we should force
4dd0: 74 68 65 20 64 65 74 65 63 74 69 6f 6e 20 6f 66 the detection of
4de0: 20 61 20 63 6f 72 72 75 70 74 65 64 20 72 65 63 a corrupted rec
4df0: 6f 72 64 0a 09 09 09 09 20 20 20 20 28 76 65 63 ord..... (vec
4e00: 74 6f 72 20 23 74 20 27 28 29 29 29 29 29 20 20 tor #t '()))))
4e10: 3b 3b 20 77 65 20 63 6f 75 6c 64 20 61 6c 73 6f ;; we could also
4e20: 20 63 68 65 63 6b 20 74 68 61 74 20 74 68 65 20 check that the
4e30: 72 65 74 75 72 6e 65 64 20 74 79 70 65 73 20 61 returned types a
4e40: 72 65 20 76 61 6c 69 64 0a 09 09 09 20 20 20 20 re valid....
4e50: 20 28 76 65 63 74 6f 72 20 23 74 20 27 28 29 29 (vector #t '())
4e60: 29 29 0a 09 20 28 73 75 63 63 65 73 73 20 20 20 )).. (success
4e70: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
4e80: 20 72 65 73 64 61 74 20 30 29 29 0a 09 20 28 72 resdat 0)).. (r
4e90: 65 73 20 20 20 20 20 20 20 20 20 20 20 20 28 76 es (v
4ea0: 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 ector-ref resdat
4eb0: 20 31 29 29 0a 09 20 28 64 75 72 61 74 69 6f 6e 1)).. (duration
4ec0: 20 20 20 20 20 20 20 28 2d 20 28 63 75 72 72 65 (- (curre
4ed0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
4ee0: 20 73 74 61 72 74 29 29 29 0a 20 20 20 20 28 69 start))). (i
4ef0: 66 20 28 61 6e 64 20 72 65 61 64 2d 6f 6e 6c 79 f (and read-only
4f00: 20 71 72 79 2d 69 73 2d 77 72 69 74 65 29 0a 20 qry-is-write).
4f10: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
4f20: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
4f30: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
4f40: 20 61 74 74 65 6d 70 74 20 74 6f 20 77 72 69 74 attempt to writ
4f50: 65 20 74 6f 20 72 65 61 64 2d 6f 6e 6c 79 20 64 e to read-only d
4f60: 61 74 61 62 61 73 65 20 69 67 6e 6f 72 65 64 2e atabase ignored.
4f70: 20 63 6d 64 3d 22 20 63 6d 64 29 29 0a 20 20 20 cmd=" cmd)).
4f80: 20 28 69 66 20 28 6e 6f 74 20 73 75 63 63 65 73 (if (not succes
4f90: 73 29 0a 09 28 69 66 20 28 3e 20 72 65 6d 72 65 s)..(if (> remre
4fa0: 74 72 69 65 73 20 30 29 0a 09 20 20 20 20 28 62 tries 0).. (b
4fb0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
4fc0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
4fd0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4fe0: 72 74 2a 20 22 6c 6f 63 61 6c 20 71 75 65 72 79 rt* "local query
4ff0: 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 failed. Trying
5000: 61 67 61 69 6e 2e 22 29 0a 09 20 20 20 20 20 20 again.")..
5010: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
5020: 2f 20 28 72 61 6e 64 6f 6d 20 35 30 30 30 29 20 / (random 5000)
5030: 31 30 30 30 29 29 20 3b 3b 20 73 6f 6d 65 20 72 1000)) ;; some r
5040: 61 6e 64 6f 6d 20 64 65 6c 61 79 20 0a 09 20 20 andom delay ..
5050: 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 (rmt:open-qr
5060: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 y-close-locally
5070: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
5080: 73 20 72 65 6d 72 65 74 72 69 65 73 3a 20 28 2d s remretries: (-
5090: 20 72 65 6d 72 65 74 72 69 65 73 20 31 29 29 29 remretries 1)))
50a0: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
50b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
50c0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
50d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 6f 6f t-log-port* "too
50e0: 20 6d 61 6e 79 20 72 65 74 72 69 65 73 20 69 6e many retries in
50f0: 20 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c rmt:open-qry-cl
5100: 6f 73 65 2d 6c 6f 63 61 6c 6c 79 2c 20 67 69 76 ose-locally, giv
5110: 69 6e 67 20 75 70 22 29 0a 09 20 20 20 20 20 20 ing up")..
5120: 23 66 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 #f))..(begin..
5130: 3b 3b 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 64 ;; (rmt:update-d
5140: 62 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 20 63 b-stats run-id c
5150: 6d 64 20 70 61 72 61 6d 73 20 64 75 72 61 74 69 md params durati
5160: 6f 6e 29 0a 09 20 20 3b 3b 20 6d 61 72 6b 20 74 on).. ;; mark t
5170: 68 69 73 20 72 75 6e 20 61 73 20 64 69 72 74 79 his run as dirty
5180: 20 69 66 20 74 68 69 73 20 77 61 73 20 61 20 77 if this was a w
5190: 72 69 74 65 2c 20 74 68 65 20 77 61 74 63 68 64 rite, the watchd
51a0: 6f 67 20 69 73 20 72 65 73 70 6f 6e 73 69 62 6c og is responsibl
51b0: 65 20 66 6f 72 20 73 79 6e 63 69 6e 67 20 69 74 e for syncing it
51c0: 0a 09 20 20 28 69 66 20 71 72 79 2d 69 73 2d 77 .. (if qry-is-w
51d0: 72 69 74 65 0a 09 20 20 20 20 20 20 28 6c 65 74 rite.. (let
51e0: 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 ((start-time (c
51f0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
5200: 29 0a 09 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 )...(mutex-lock!
5210: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
5220: 6d 75 74 65 78 2a 29 0a 2f 09 09 28 73 65 74 21 mutex*)./..(set!
5230: 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
5240: 2a 20 73 74 61 72 74 2d 74 69 6d 65 29 20 20 3b * start-time) ;
5250: 3b 20 54 48 49 53 20 49 53 20 50 52 4f 42 41 42 ; THIS IS PROBAB
5260: 4c 59 20 55 53 45 4c 45 53 53 3f 20 28 77 65 20 LY USELESS? (we
5270: 61 72 65 20 6f 6e 20 61 20 63 6c 69 65 6e 74 29 are on a client)
5280: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5290: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
52a0: 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d *db-multi-sync-m
52b0: 75 74 65 78 2a 29 29 29 29 29 0a 20 20 20 20 72 utex*))))). r
52c0: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 es))..(define (r
52d0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d mt:send-receive-
52e0: 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 no-auto-client-s
52f0: 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d etup connection-
5300: 69 6e 66 6f 20 63 6d 64 20 72 75 6e 2d 69 64 20 info cmd run-id
5310: 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 params). (let*
5320: 28 28 72 75 6e 2d 69 64 20 20 20 28 69 66 20 72 ((run-id (if r
5330: 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 30 29 29 un-id run-id 0))
5340: 0a 09 20 28 72 65 73 20 20 09 20 20 20 28 68 61 .. (res . (ha
5350: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
5360: 09 09 20 20 20 20 65 78 6e 0a 09 09 20 20 20 20 .. exn...
5370: 23 66 0a 09 09 20 20 20 20 28 68 74 74 70 2d 74 #f... (http-t
5380: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
5390: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
53a0: 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 run-id connecti
53b0: 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 70 61 72 61 on-info cmd para
53c0: 6d 73 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 ms)))). (if (
53d0: 61 6e 64 20 72 65 73 20 28 76 65 63 74 6f 72 2d and res (vector-
53e0: 72 65 66 20 72 65 73 20 30 29 29 0a 09 28 76 65 ref res 0))..(ve
53f0: 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 ctor-ref res 1)
5400: 3b 3b 3b 20 59 45 53 21 21 20 54 48 49 53 20 49 ;;; YES!! THIS I
5410: 53 20 43 4f 52 52 45 43 54 21 21 20 43 48 41 4e S CORRECT!! CHAN
5420: 47 45 20 49 54 20 48 45 52 45 2c 20 54 48 45 4e GE IT HERE, THEN
5430: 20 43 48 41 4e 47 45 20 72 6d 74 3a 73 65 6e 64 CHANGE rmt:send
5440: 2d 72 65 63 65 69 76 65 20 41 4c 53 4f 21 21 21 -receive ALSO!!!
5450: 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 3b 3b 20 57 ..#f)))..;; ;; W
5460: 72 61 70 20 6a 73 6f 6e 20 6c 69 62 72 61 72 79 rap json library
5470: 20 66 6f 72 20 73 74 72 69 6e 67 73 20 28 77 68 for strings (wh
5480: 79 20 74 68 65 20 70 6f 72 74 73 20 63 72 61 70 y the ports crap
5490: 20 69 6e 20 74 68 65 20 66 69 72 73 74 20 70 6c in the first pl
54a0: 61 63 65 3f 29 0a 3b 3b 20 28 64 65 66 69 6e 65 ace?).;; (define
54b0: 20 28 72 6d 74 3a 64 61 74 2d 3e 6a 73 6f 6e 2d (rmt:dat->json-
54c0: 73 74 72 20 64 61 74 29 0a 3b 3b 20 20 20 28 77 str dat).;; (w
54d0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 ith-output-to-st
54e0: 72 69 6e 67 20 0a 3b 3b 20 20 20 20 20 28 6c 61 ring .;; (la
54f0: 6d 62 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 20 mbda ().;;
5500: 20 28 6a 73 6f 6e 2d 77 72 69 74 65 20 64 61 74 (json-write dat
5510: 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 )))).;; .;; (def
5520: 69 6e 65 20 28 72 6d 74 3a 6a 73 6f 6e 2d 73 74 ine (rmt:json-st
5530: 72 2d 3e 64 61 74 20 6a 73 6f 6e 2d 73 74 72 29 r->dat json-str)
5540: 0a 3b 3b 20 20 20 28 77 69 74 68 2d 69 6e 70 75 .;; (with-inpu
5550: 74 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 20 6a 73 t-from-string js
5560: 6f 6e 2d 73 74 72 0a 3b 3b 20 20 20 20 20 28 6c on-str.;; (l
5570: 61 6d 62 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 ambda ().;;
5580: 20 20 28 6a 73 6f 6e 2d 72 65 61 64 29 29 29 29 (json-read))))
5590: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
55a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b ==========.;;.;;
55e0: 20 41 20 43 20 54 20 55 20 41 20 4c 20 20 20 41 A C T U A L A
55f0: 20 50 20 49 20 20 20 43 20 41 20 4c 20 4c 20 53 P I C A L L S
5600: 20 20 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .;;.;;========
5610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
5650: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
5660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5690: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 45 ========.;; S E
56a0: 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d R V E R.;;=====
56b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56f0: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
5700: 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 75 6e 2d kill-server run-
5710: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
5720: 72 65 63 65 69 76 65 20 27 6b 69 6c 6c 2d 73 65 receive 'kill-se
5730: 72 76 65 72 20 72 75 6e 2d 69 64 20 28 6c 69 73 rver run-id (lis
5740: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
5750: 66 69 6e 65 20 28 72 6d 74 3a 73 74 61 72 74 2d fine (rmt:start-
5760: 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a 20 server run-id).
5770: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
5780: 76 65 20 27 73 74 61 72 74 2d 73 65 72 76 65 72 ve 'start-server
5790: 20 30 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 0 (list run-id)
57a0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
57b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
57c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
57d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
57e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
57f0: 20 4d 20 49 20 53 20 43 0a 3b 3b 3d 3d 3d 3d 3d M I S C.;;=====
5800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5840: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
5850: 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 29 0a 20 20 login run-id).
5860: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5870: 65 20 27 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 20 e 'login run-id
5880: 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 (list *toppath*
5890: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
58a0: 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e *my-client-sign
58b0: 61 74 75 72 65 2a 29 29 29 0a 0a 3b 3b 20 54 68 ature*)))..;; Th
58c0: 69 73 20 6c 6f 67 69 6e 20 64 6f 65 73 20 6e 6f is login does no
58d0: 20 72 65 74 72 69 65 73 20 75 6e 64 65 72 20 74 retries under t
58e0: 68 65 20 68 6f 6f 64 20 2d 20 69 74 20 61 63 74 he hood - it act
58f0: 73 20 61 20 62 69 74 20 6c 69 6b 65 20 61 20 70 s a bit like a p
5900: 69 6e 67 2e 0a 3b 3b 20 44 65 70 72 65 63 61 74 ing..;; Deprecat
5910: 65 64 20 66 6f 72 20 6e 6d 73 67 2d 74 72 61 6e ed for nmsg-tran
5920: 73 70 6f 72 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e sport..;;.(defin
5930: 65 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d e (rmt:login-no-
5940: 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 auto-client-setu
5950: 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 p connection-inf
5960: 6f 29 0a 20 20 28 63 61 73 65 20 2a 74 72 61 6e o). (case *tran
5970: 73 70 6f 72 74 2d 74 79 70 65 2a 20 3b 3b 20 72 sport-type* ;; r
5980: 75 6e 2d 69 64 20 6f 66 20 30 20 69 73 20 6a 75 un-id of 0 is ju
5990: 73 74 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 st a placeholder
59a0: 0a 20 20 20 20 28 28 68 74 74 70 29 28 72 6d 74 . ((http)(rmt
59b0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f :send-receive-no
59c0: 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 -auto-client-set
59d0: 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e up connection-in
59e0: 66 6f 20 27 6c 6f 67 69 6e 20 30 20 28 6c 69 73 fo 'login 0 (lis
59f0: 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 t *toppath* mega
5a00: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 2a 6d 79 test-version *my
5a10: 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 -client-signatur
5a20: 65 2a 29 29 29 0a 20 20 20 20 3b 3b 28 28 6e 6d e*))). ;;((nm
5a30: 73 67 29 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f sg)(nmsg-transpo
5a40: 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 rt:client-api-se
5a50: 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 nd-receive run-i
5a60: 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 d connection-inf
5a70: 6f 20 27 6c 6f 67 69 6e 20 28 6c 69 73 74 20 2a o 'login (list *
5a80: 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 74 65 73 toppath* megates
5a90: 74 2d 76 65 72 73 69 6f 6e 20 72 75 6e 2d 69 64 t-version run-id
5aa0: 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e *my-client-sign
5ab0: 61 74 75 72 65 2a 29 29 29 0a 20 20 20 20 29 29 ature*))). ))
5ac0: 0a 0a 3b 3b 20 68 61 6e 64 20 6f 66 66 20 61 20 ..;; hand off a
5ad0: 63 61 6c 6c 20 74 6f 20 6f 6e 65 20 6f 66 20 74 call to one of t
5ae0: 68 65 20 64 62 3a 71 75 65 72 69 65 73 20 73 74 he db:queries st
5af0: 61 74 65 6d 65 6e 74 73 0a 3b 3b 20 61 64 64 65 atements.;; adde
5b00: 64 20 72 75 6e 2d 69 64 20 74 6f 20 6d 61 6b 65 d run-id to make
5b10: 20 6c 6f 6f 6b 69 6e 67 20 75 70 20 74 68 65 20 looking up the
5b20: 63 6f 72 72 65 63 74 20 64 62 20 70 6f 73 73 69 correct db possi
5b30: 62 6c 65 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ble .;;.(define
5b40: 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
5b50: 6c 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 l stmtname run-i
5b60: 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 72 d . params). (r
5b70: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
5b80: 27 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 72 75 'general-call ru
5b90: 6e 2d 69 64 20 28 61 70 70 65 6e 64 20 28 6c 69 n-id (append (li
5ba0: 73 74 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d st stmtname run-
5bb0: 69 64 29 20 70 61 72 61 6d 73 29 29 29 0a 0a 0a id) params)))...
5bc0: 3b 3b 20 67 69 76 65 6e 20 61 20 68 6f 73 74 6e ;; given a hostn
5bd0: 61 6d 65 2c 20 72 65 74 75 72 6e 20 61 20 70 61 ame, return a pa
5be0: 69 72 20 6f 66 20 63 70 75 20 6c 6f 61 64 20 61 ir of cpu load a
5bf0: 6e 64 20 75 70 64 61 74 65 20 74 69 6d 65 20 72 nd update time r
5c00: 65 70 72 65 73 65 6e 74 69 6e 67 20 6c 61 74 65 epresenting late
5c10: 73 74 20 69 6e 74 65 6c 6c 69 67 65 6e 63 65 20 st intelligence
5c20: 66 72 6f 6d 20 74 65 73 74 73 20 72 75 6e 6e 69 from tests runni
5c30: 6e 67 20 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a ng on that host.
5c40: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
5c50: 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 -latest-host-loa
5c60: 64 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 d hostname). (r
5c70: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
5c80: 27 67 65 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 'get-latest-host
5c90: 2d 6c 6f 61 64 20 30 20 28 6c 69 73 74 20 68 6f -load 0 (list ho
5ca0: 73 74 6e 61 6d 65 29 29 29 0a 0a 3b 3b 20 28 64 stname)))..;; (d
5cb0: 65 66 69 6e 65 20 28 72 6d 74 3a 73 79 6e 63 2d efine (rmt:sync-
5cc0: 69 6e 6d 65 6d 2d 3e 64 62 20 72 75 6e 2d 69 64 inmem->db run-id
5cd0: 29 0a 3b 3b 20 20 20 28 72 6d 74 3a 73 65 6e 64 ).;; (rmt:send
5ce0: 2d 72 65 63 65 69 76 65 20 27 73 79 6e 63 2d 69 -receive 'sync-i
5cf0: 6e 6d 65 6d 2d 3e 64 62 20 72 75 6e 2d 69 64 20 nmem->db run-id
5d00: 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 '()))..(define (
5d10: 72 6d 74 3a 73 64 62 2d 71 72 79 20 71 72 79 20 rmt:sdb-qry qry
5d20: 76 61 6c 20 72 75 6e 2d 69 64 29 0a 20 20 3b 3b val run-id). ;;
5d30: 20 61 64 64 20 63 61 63 68 69 6e 67 20 69 66 20 add caching if
5d40: 71 72 79 20 69 73 20 27 67 65 74 69 64 20 6f 72 qry is 'getid or
5d50: 20 27 67 65 74 73 74 72 0a 20 20 28 72 6d 74 3a 'getstr. (rmt:
5d60: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 64 send-receive 'sd
5d70: 62 2d 71 72 79 20 72 75 6e 2d 69 64 20 28 6c 69 b-qry run-id (li
5d80: 73 74 20 71 72 79 20 76 61 6c 29 29 29 0a 0a 3b st qry val)))..;
5d90: 3b 20 4e 4f 54 20 43 4f 4d 50 4c 45 54 45 44 0a ; NOT COMPLETED.
5da0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 75 6e (define (rmt:run
5db0: 74 65 73 74 73 20 75 73 65 72 20 72 75 6e 2d 69 tests user run-i
5dc0: 64 20 74 65 73 74 70 61 74 74 20 70 61 72 61 6d d testpatt param
5dd0: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
5de0: 65 63 65 69 76 65 20 27 72 75 6e 74 65 73 74 73 eceive 'runtests
5df0: 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 run-id testpatt
5e00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5e10: 3a 67 65 74 2d 72 75 6e 2d 72 65 63 6f 72 64 2d :get-run-record-
5e20: 69 64 73 20 20 74 61 72 67 65 74 20 72 75 6e 20 ids target run
5e30: 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 keynames test-pa
5e40: 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d tt). (rmt:send-
5e50: 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e receive 'get-run
5e60: 2d 72 65 63 6f 72 64 2d 69 64 73 20 23 66 20 28 -record-ids #f (
5e70: 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 6e 20 list target run
5e80: 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 keynames test-pa
5e90: 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 tt)))..(define (
5ea0: 72 6d 74 3a 67 65 74 2d 63 68 61 6e 67 65 64 2d rmt:get-changed-
5eb0: 72 65 63 6f 72 64 2d 69 64 73 20 73 69 6e 63 65 record-ids since
5ec0: 2d 74 69 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 -time). (rmt:se
5ed0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
5ee0: 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 changed-record-i
5ef0: 64 73 20 23 66 20 28 6c 69 73 74 20 73 69 6e 63 ds #f (list sinc
5f00: 65 2d 74 69 6d 65 29 29 20 29 0a 0a 3b 3b 3d 3d e-time)) )..;;==
5f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f50: 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
5f60: 20 20 20 4d 20 45 20 54 20 41 20 0a 3b 3b 3d 3d M E T A .;;==
5f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fb0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
5fc0: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 74 61 67 mt:get-tests-tag
5fd0: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
5fe0: 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 eceive 'get-test
5ff0: 73 2d 74 61 67 73 20 23 66 20 27 28 29 29 29 0a s-tags #f '())).
6000: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4b 20 =========.;; K
6050: 45 20 59 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E Y S .;;=======
6060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
60a0: 0a 3b 3b 20 54 68 65 73 65 20 72 65 71 75 69 72 .;; These requir
60b0: 65 20 72 75 6e 2d 69 64 20 62 65 63 61 75 73 65 e run-id because
60c0: 20 74 68 65 20 76 61 6c 75 65 73 20 63 6f 6d 65 the values come
60d0: 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 21 0a 3b from the run!.;
60e0: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ;.(define (rmt:g
60f0: 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 et-key-val-pairs
6100: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
6110: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
6120: 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 t-key-val-pairs
6130: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
6140: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
6150: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 0a 20 (rmt:get-keys).
6160: 20 28 69 66 20 2a 64 62 2d 6b 65 79 73 2a 20 2a (if *db-keys* *
6170: 64 62 2d 6b 65 79 73 2a 20 0a 20 20 20 20 20 28 db-keys* . (
6180: 6c 65 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 let ((res (rmt:s
6190: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
61a0: 2d 6b 65 79 73 20 23 66 20 27 28 29 29 29 29 0a -keys #f '()))).
61b0: 20 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 (set! *db
61c0: 2d 6b 65 79 73 2a 20 72 65 73 29 0a 20 20 20 20 -keys* res).
61d0: 20 20 20 72 65 73 29 29 29 0a 0a 28 64 65 66 69 res)))..(defi
61e0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 ne (rmt:get-keys
61f0: 2d 77 72 69 74 65 29 20 3b 3b 20 64 75 6d 6d 79 -write) ;; dummy
6200: 20 71 75 65 72 79 20 74 6f 20 66 6f 72 63 65 20 query to force
6210: 73 65 72 76 65 72 20 73 74 61 72 74 0a 20 20 28 server start. (
6220: 6c 65 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 let ((res (rmt:s
6230: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
6240: 2d 6b 65 79 73 2d 77 72 69 74 65 20 23 66 20 27 -keys-write #f '
6250: 28 29 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 ()))). (set!
6260: 2a 64 62 2d 6b 65 79 73 2a 20 72 65 73 29 0a 20 *db-keys* res).
6270: 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 77 65 20 res))..;; we
6280: 64 6f 6e 27 74 20 72 65 75 73 65 20 72 75 6e 2d don't reuse run-
6290: 69 64 27 73 20 28 65 78 63 65 70 74 20 70 6f 73 id's (except pos
62a0: 73 69 62 6c 79 20 2a 61 66 74 65 72 2a 20 61 20 sibly *after* a
62b0: 64 62 20 63 6c 65 61 6e 75 70 29 20 73 6f 20 69 db cleanup) so i
62c0: 74 20 69 73 20 73 61 66 65 0a 3b 3b 20 74 6f 20 t is safe.;; to
62d0: 63 61 63 68 65 20 74 68 65 20 72 65 73 75 6c 73 cache the resuls
62e0: 20 69 6e 20 61 20 68 61 73 68 0a 3b 3b 0a 28 64 in a hash.;;.(d
62f0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b efine (rmt:get-k
6300: 65 79 2d 76 61 6c 73 20 72 75 6e 2d 69 64 29 0a ey-vals run-id).
6310: 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c (or (hash-tabl
6320: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 6b e-ref/default *k
6330: 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 23 eyvals* run-id #
6340: 66 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 f). (let ((
6350: 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 res (rmt:send-re
6360: 63 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 ceive 'get-key-v
6370: 61 6c 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e als #f (list run
6380: 2d 69 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 -id)))).
6390: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
63a0: 20 2a 6b 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 *keyvals* run-i
63b0: 64 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 d res). r
63c0: 65 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 es)))..(define (
63d0: 72 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 73 29 rmt:get-targets)
63e0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
63f0: 65 69 76 65 20 27 67 65 74 2d 74 61 72 67 65 74 eive 'get-target
6400: 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 s #f '()))..(def
6410: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 61 72 ine (rmt:get-tar
6420: 67 65 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 get run-id). (r
6430: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
6440: 27 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d 'get-target run-
6450: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 id (list run-id)
6460: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6470: 3a 67 65 74 2d 72 75 6e 2d 74 69 6d 65 73 20 72 :get-run-times r
6480: 75 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 74 unpatt targetpat
6490: 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 t). (rmt:send-r
64a0: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d eceive 'get-run-
64b0: 74 69 6d 65 73 20 23 66 20 28 6c 69 73 74 20 72 times #f (list r
64c0: 75 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 74 unpatt targetpat
64d0: 74 20 29 29 29 20 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d t ))) ...;;=====
64e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6520: 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 53 0a =.;; T E S T S.
6530: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6570: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4a 75 73 ========..;; Jus
6580: 74 20 73 6f 6d 65 20 73 79 6e 74 61 74 69 63 20 t some syntatic
6590: 73 75 67 61 72 0a 28 64 65 66 69 6e 65 20 28 72 sugar.(define (r
65a0: 6d 74 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 mt:register-test
65b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
65c0: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 e item-path). (
65d0: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
65e0: 20 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 'register-test
65f0: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 run-id run-id te
6600: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
6610: 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d h))..(define (rm
6620: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
6630: 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 n-id testname it
6640: 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a em-path). (rmt:
6650: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
6660: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
6670: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
6680: 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 stname item-path
6690: 29 29 29 0a 0a 3b 3b 20 72 75 6e 2d 69 64 20 69 )))..;; run-id i
66a0: 73 20 4e 4f 54 20 75 73 65 64 0a 3b 3b 0a 28 64 s NOT used.;;.(d
66b0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
66c0: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 est-info-by-id r
66d0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 un-id test-id).
66e0: 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 74 65 (if (number? te
66f0: 73 74 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d st-id). (rm
6700: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
6710: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
6720: 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 -id run-id (list
6730: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
6740: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ). (begin..
6750: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
6760: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6770: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 42 61 64 20 * "WARNING: Bad
6780: 64 61 74 61 20 68 61 6e 64 65 64 20 74 6f 20 72 data handed to r
6790: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
67a0: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 3d 22 20 -by-id run-id="
67b0: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 run-id ", test-i
67c0: 64 3d 22 20 74 65 73 74 2d 69 64 29 0a 09 28 70 d=" test-id)..(p
67d0: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
67e0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
67f0: 6f 72 74 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 ort))..#f)))..(d
6800: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
6810: 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d get-rundir-from-
6820: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
6830: 65 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 est-id). (rmt:s
6840: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
6850: 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f t-get-rundir-fro
6860: 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 m-test-id run-id
6870: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
6880: 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e st-id)))..(defin
6890: 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 74 65 73 74 e (rmt:open-test
68a0: 2d 64 62 2d 62 79 2d 74 65 73 74 2d 69 64 20 72 -db-by-test-id r
68b0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 23 21 un-id test-id #!
68c0: 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 key (work-area #
68d0: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 f)). (let* ((te
68e0: 73 74 2d 70 61 74 68 20 28 69 66 20 28 73 74 72 st-path (if (str
68f0: 69 6e 67 3f 20 77 6f 72 6b 2d 61 72 65 61 29 0a ing? work-area).
6900: 09 09 09 77 6f 72 6b 2d 61 72 65 61 0a 09 09 09 ...work-area....
6910: 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 75 (rmt:test-get-ru
6920: 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 ndir-from-test-i
6930: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
6940: 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a )))). (debug:
6950: 70 72 69 6e 74 20 33 20 2a 64 65 66 61 75 6c 74 print 3 *default
6960: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 45 53 54 -log-port* "TEST
6970: 20 50 41 54 48 3a 20 22 20 74 65 73 74 2d 70 61 PATH: " test-pa
6980: 74 68 29 0a 20 20 20 20 28 6f 70 65 6e 2d 74 65 th). (open-te
6990: 73 74 2d 64 62 20 74 65 73 74 2d 70 61 74 68 29 st-db test-path)
69a0: 29 29 0a 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 ))..;; WARNING:
69b0: 54 68 69 73 20 63 75 72 72 65 6e 74 6c 79 20 62 This currently b
69c0: 79 70 61 73 73 65 73 20 74 68 65 20 74 72 61 6e ypasses the tran
69d0: 73 61 63 74 69 6f 6e 20 77 72 61 70 70 65 64 20 saction wrapped
69e0: 77 72 69 74 65 73 20 73 79 73 74 65 6d 0a 28 64 writes system.(d
69f0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
6a00: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
6a10: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
6a20: 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e st-id newstate n
6a30: 65 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d ewstatus newcomm
6a40: 65 6e 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ent). (rmt:send
6a50: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 73 -receive 'test-s
6a60: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
6a70: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 by-id run-id (li
6a80: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
6a90: 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 d newstate newst
6aa0: 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 atus newcomment)
6ab0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6ac0: 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 :set-tests-state
6ad0: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 20 -status run-id
6ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6af0: 20 20 20 20 74 65 73 74 6e 61 6d 65 73 20 63 75 testnames cu
6b00: 72 72 73 74 61 74 65 20 63 75 72 72 73 74 61 74 rrstate currstat
6b10: 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 us newstate news
6b20: 74 61 74 75 73 29 0a 20 20 28 72 6d 74 3a 73 65 tatus). (rmt:se
6b30: 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d nd-receive 'set-
6b40: 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 tests-state-stat
6b50: 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 us run-id (list
6b60: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 run-id testnames
6b70: 20 63 75 72 72 73 74 61 74 65 20 63 75 72 72 73 currstate currs
6b80: 74 61 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e tatus newstate n
6b90: 65 77 73 74 61 74 75 73 29 29 29 0a 0a 28 64 65 ewstatus)))..(de
6ba0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 fine (rmt:get-te
6bb0: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d sts-for-run run-
6bc0: 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 id testpatt stat
6bd0: 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 66 73 es statuses offs
6be0: 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 et limit not-in
6bf0: 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 sort-by sort-ord
6c00: 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d er qryvals last-
6c10: 75 70 64 61 74 65 20 6d 6f 64 65 29 0a 20 20 3b update mode). ;
6c20: 3b 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 ; (if (number? r
6c30: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
6c40: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
6c50: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 tests-for-run ru
6c60: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
6c70: 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 d testpatt state
6c80: 73 20 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 s statuses offse
6c90: 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 t limit not-in s
6ca0: 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 ort-by sort-orde
6cb0: 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 r qryvals last-u
6cc0: 70 64 61 74 65 20 6d 6f 64 65 29 29 29 0a 20 20 pdate mode))).
6cd0: 3b 3b 20 20 20 20 28 62 65 67 69 6e 0a 20 20 3b ;; (begin. ;
6ce0: 3b 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ;.(debug:print-e
6cf0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
6d00: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 67 log-port* "rmt:g
6d10: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
6d20: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 62 61 64 called with bad
6d30: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
6d40: 29 0a 20 20 3b 3b 09 28 70 72 69 6e 74 2d 63 61 ). ;;.(print-ca
6d50: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
6d60: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
6d70: 20 3b 3b 09 27 28 29 29 29 29 0a 0a 3b 3b 20 67 ;;.'())))..;; g
6d80: 65 74 20 73 74 75 66 66 20 76 69 61 20 73 79 6e et stuff via syn
6d90: 63 68 61 73 68 20 0a 28 64 65 66 69 6e 65 20 28 chash .(define (
6da0: 72 6d 74 3a 73 79 6e 63 68 61 73 68 2d 67 65 74 rmt:synchash-get
6db0: 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 79 6e run-id proc syn
6dc0: 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 72 61 ckey keynum para
6dd0: 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ms). (rmt:send-
6de0: 72 65 63 65 69 76 65 20 27 73 79 6e 63 68 61 73 receive 'synchas
6df0: 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 h-get run-id (li
6e00: 73 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 st run-id proc s
6e10: 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 ynckey keynum pa
6e20: 72 61 6d 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 rams)))..(define
6e30: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d (rmt:get-tests-
6e40: 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 for-run-mindata
6e50: 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 run-id testpatt
6e60: 73 74 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f states status no
6e70: 74 2d 69 6e 29 0a 20 20 28 72 6d 74 3a 73 65 6e t-in). (rmt:sen
6e80: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
6e90: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e ests-for-run-min
6ea0: 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 data run-id (lis
6eb0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 t run-id testpat
6ec0: 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 t states status
6ed0: 6e 6f 74 2d 69 6e 29 29 29 0a 20 20 0a 3b 3b 20 not-in))). .;;
6ee0: 49 44 45 41 3a 20 54 68 72 65 61 64 69 66 79 20 IDEA: Threadify
6ef0: 74 68 65 73 65 20 2d 20 74 68 65 79 20 73 70 65 these - they spe
6f00: 6e 64 20 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 nd a lot of time
6f10: 20 77 61 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a waiting ....;;.
6f20: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
6f30: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d -tests-for-runs-
6f40: 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 mindata run-ids
6f50: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
6f60: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 status not-in).
6f70: 20 28 6c 65 74 20 28 28 6d 75 6c 74 69 2d 72 75 (let ((multi-ru
6f80: 6e 2d 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 n-mutex (make-mu
6f90: 74 65 78 29 29 0a 09 28 72 75 6e 2d 69 64 2d 6c tex))..(run-id-l
6fa0: 69 73 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a ist (if run-ids.
6fb0: 09 09 09 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 ... run-ids....
6fc0: 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e (rmt:get-all-run
6fd0: 2d 69 64 73 29 29 29 0a 09 28 72 65 73 75 6c 74 -ids)))..(result
6fe0: 20 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 '())).
6ff0: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 (if (null? run-i
7000: 64 2d 6c 69 73 74 29 0a 09 27 28 29 0a 09 28 6c d-list)..'()..(l
7010: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 et loop ((hed
7020: 20 20 28 63 61 72 20 72 75 6e 2d 69 64 2d 6c 69 (car run-id-li
7030: 73 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 st))... (tal
7040: 20 20 20 28 63 64 72 20 72 75 6e 2d 69 64 2d 6c (cdr run-id-l
7050: 69 73 74 29 29 0a 09 09 20 20 20 28 74 68 72 65 ist))... (thre
7060: 61 64 73 20 27 28 29 29 29 0a 09 20 20 28 69 66 ads '())).. (if
7070: 20 28 3e 20 28 6c 65 6e 67 74 68 20 74 68 72 65 (> (length thre
7080: 61 64 73 29 20 35 29 0a 09 20 20 20 20 20 20 28 ads) 5).. (
7090: 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 28 66 69 loop hed tal (fi
70a0: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 68 lter (lambda (th
70b0: 29 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 )(not (member (t
70c0: 68 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 hread-state th)
70d0: 27 28 74 65 72 6d 69 6e 61 74 65 64 20 64 65 61 '(terminated dea
70e0: 64 29 29 29 29 20 74 68 72 65 61 64 73 29 29 0a d)))) threads)).
70f0: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e . (let* ((n
7100: 65 77 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 ewthread (make-t
7110: 68 72 65 61 64 0a 09 09 09 09 20 28 6c 61 6d 62 hread..... (lamb
7120: 64 61 20 28 29 0a 09 09 09 09 20 20 20 28 6c 65 da ()..... (le
7130: 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e t ((res (rmt:sen
7140: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
7150: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e ests-for-run-min
7160: 64 61 74 61 20 68 65 64 20 28 6c 69 73 74 20 68 data hed (list h
7170: 65 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 ed testpatt stat
7180: 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e es status not-in
7190: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 69 ))))..... (i
71a0: 66 20 28 6c 69 73 74 3f 20 72 65 73 29 0a 09 09 f (list? res)...
71b0: 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 09 ... (begin......
71c0: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
71d0: 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 multi-run-mutex)
71e0: 0a 09 09 09 09 09 20 20 20 28 73 65 74 21 20 72 ...... (set! r
71f0: 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 esult (append re
7200: 73 75 6c 74 20 72 65 73 29 29 0a 09 09 09 09 09 sult res))......
7210: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
7220: 21 20 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 ! multi-run-mute
7230: 78 29 29 0a 09 09 09 09 09 20 28 64 65 62 75 67 x))...... (debug
7240: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
7250: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7260: 2a 20 22 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 * "get-tests-for
7270: 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 66 61 69 -run-mindata fai
7280: 6c 65 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 led for run-id "
7290: 20 68 65 64 20 22 2c 20 74 65 73 74 70 61 74 74 hed ", testpatt
72a0: 20 22 20 74 65 73 74 70 61 74 74 20 22 2c 20 73 " testpatt ", s
72b0: 74 61 74 65 73 20 22 20 73 74 61 74 65 73 20 22 tates " states "
72c0: 2c 20 73 74 61 74 75 73 20 22 20 73 74 61 74 75 , status " statu
72d0: 73 20 22 2c 20 6e 6f 74 2d 69 6e 20 22 20 6e 6f s ", not-in " no
72e0: 74 2d 69 6e 29 29 29 29 0a 09 09 09 09 20 28 63 t-in))))..... (c
72f0: 6f 6e 63 20 22 6d 75 6c 74 69 2d 72 75 6e 2d 74 onc "multi-run-t
7300: 68 72 65 61 64 20 66 6f 72 20 72 75 6e 2d 69 64 hread for run-id
7310: 20 22 20 68 65 64 29 29 29 0a 09 09 20 20 20 20 " hed)))...
7320: 20 28 6e 65 77 74 68 72 65 61 64 73 20 28 63 6f (newthreads (co
7330: 6e 73 20 6e 65 77 74 68 72 65 61 64 20 74 68 72 ns newthread thr
7340: 65 61 64 73 29 29 29 0a 09 09 28 74 68 72 65 61 eads)))...(threa
7350: 64 2d 73 74 61 72 74 21 20 6e 65 77 74 68 72 65 d-start! newthre
7360: 61 64 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c ad)...(thread-sl
7370: 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 67 69 eep! 0.05) ;; gi
7380: 76 65 20 74 68 61 74 20 74 68 72 65 61 64 20 73 ve that thread s
7390: 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 ome time to star
73a0: 74 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 t...(if (null? t
73b0: 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 74 68 72 al)... newthr
73c0: 65 61 64 73 0a 09 09 20 20 20 20 28 6c 6f 6f 70 eads... (loop
73d0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
73e0: 61 6c 29 20 6e 65 77 74 68 72 65 61 64 73 29 29 al) newthreads))
73f0: 29 29 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 )))). result)
7400: 29 0a 0a 3b 3b 20 3b 3b 20 49 44 45 41 3a 20 54 )..;; ;; IDEA: T
7410: 68 72 65 61 64 69 66 79 20 74 68 65 73 65 20 2d hreadify these -
7420: 20 74 68 65 79 20 73 70 65 6e 64 20 61 20 6c 6f they spend a lo
7430: 74 20 6f 66 20 74 69 6d 65 20 77 61 69 74 69 6e t of time waitin
7440: 67 20 2e 2e 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 g ....;; ;;.;; (
7450: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
7460: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d tests-for-runs-m
7470: 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 74 indata run-ids t
7480: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
7490: 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 3b 3b tatus not-in).;;
74a0: 20 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 (let ((run-id
74b0: 2d 6c 69 73 74 20 28 69 66 20 72 75 6e 2d 69 64 -list (if run-id
74c0: 73 0a 3b 3b 20 09 09 09 20 72 75 6e 2d 69 64 73 s.;; ... run-ids
74d0: 0a 3b 3b 20 09 09 09 20 28 72 6d 74 3a 67 65 74 .;; ... (rmt:get
74e0: 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 29 -all-run-ids))))
74f0: 0a 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 20 61 .;; (apply a
7500: 70 70 65 6e 64 20 28 6d 61 70 20 28 6c 61 6d 62 ppend (map (lamb
7510: 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 da (run-id).;; .
7520: 09 09 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 .. (rmt:send-rec
7530: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d eive 'get-tests-
7540: 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 for-run-mindata
7550: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
7560: 2d 69 64 73 20 74 65 73 74 70 61 74 74 20 73 74 -ids testpatt st
7570: 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d ates status not-
7580: 69 6e 29 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 in))).;; ..
7590: 20 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 29 run-id-list)))
75a0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
75b0: 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f delete-test-reco
75c0: 72 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d rds run-id test-
75d0: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
75e0: 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d receive 'delete-
75f0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 75 6e test-records run
7600: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7610: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 3b 3b 20 test-id)))..;;
7620: 54 68 69 73 20 69 73 20 6e 6f 74 20 6e 65 65 64 This is not need
7630: 65 64 20 61 73 20 74 65 73 74 20 73 74 65 70 73 ed as test steps
7640: 20 61 72 65 20 64 65 6c 65 74 65 64 20 6f 6e 20 are deleted on
7650: 74 65 73 74 20 64 65 6c 65 74 65 20 63 61 6c 6c test delete call
7660: 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 .;;.;; (define (
7670: 72 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d rmt:delete-test-
7680: 73 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 6e step-records run
7690: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 3b 3b 20 -id test-id).;;
76a0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
76b0: 69 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 74 ive 'delete-test
76c0: 2d 73 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 -step-records ru
76d0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
76e0: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 d test-id)))..(d
76f0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
7700: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
7710: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
7720: 73 74 61 74 65 20 73 74 61 74 75 73 20 6d 73 67 state status msg
7730: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7740: 63 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d ceive 'test-set-
7750: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
7760: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7770: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 test-id state s
7780: 74 61 74 75 73 20 6d 73 67 29 29 29 0a 0a 28 64 tatus msg)))..(d
7790: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
77a0: 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 toplevel-num-ite
77b0: 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ms run-id test-n
77c0: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
77d0: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 74 -receive 'test-t
77e0: 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d oplevel-num-item
77f0: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
7800: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
7810: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
7820: 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 rmt:get-previous
7830: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
7840: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
7850: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 e item-path).;;
7860: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7870: 69 76 65 20 27 67 65 74 2d 70 72 65 76 69 6f 75 ive 'get-previou
7880: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
7890: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
78a0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
78b0: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 item-path)))..(d
78c0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d efine (rmt:get-m
78d0: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
78e0: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
78f0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
7900: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 me item-path).
7910: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7920: 65 20 27 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d e 'get-matching-
7930: 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 previous-test-ru
7940: 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 n-records run-id
7950: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
7960: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
7970: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 h)))..(define (r
7980: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 mt:test-get-logf
7990: 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 ile-info run-id
79a0: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d test-name). (rm
79b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
79c0: 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 test-get-logfile
79d0: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c 69 -info run-id (li
79e0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e st run-id test-n
79f0: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
7a00: 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 (rmt:test-get-re
7a10: 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d cords-for-index-
7a20: 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 file run-id test
7a30: 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 -name). (rmt:se
7a40: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
7a50: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
7a60: 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d -index-file run-
7a70: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
7a80: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 test-name)))..(d
7a90: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
7aa0: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
7ab0: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
7ac0: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
7ad0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
7ae0: 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 stinfo-state-sta
7af0: 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 tus run-id (list
7b00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
7b10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7b20: 3a 74 65 73 74 2d 73 65 74 2d 6c 6f 67 21 20 72 :test-set-log! r
7b30: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6c 6f un-id test-id lo
7b40: 67 66 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e gf). (if (strin
7b50: 67 3f 20 6c 6f 67 66 29 28 72 6d 74 3a 67 65 6e g? logf)(rmt:gen
7b60: 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 2d eral-call 'test-
7b70: 73 65 74 2d 6c 6f 67 20 72 75 6e 2d 69 64 20 6c set-log run-id l
7b80: 6f 67 66 20 74 65 73 74 2d 69 64 29 29 29 0a 0a ogf test-id)))..
7b90: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
7ba0: 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-set-top-proces
7bb0: 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 65 73 s-pid run-id tes
7bc0: 74 2d 69 64 20 70 69 64 29 0a 20 20 28 72 6d 74 t-id pid). (rmt
7bd0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
7be0: 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 est-set-top-proc
7bf0: 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 28 ess-pid 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 69 64 20 70 69 64 29 29 29 0a 0a 28 64 65 66 -id pid)))..(def
7c20: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 ine (rmt:test-ge
7c30: 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 t-top-process-pi
7c40: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
7c50: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7c60: 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d ceive 'test-get-
7c70: 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 top-process-pid
7c80: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
7c90: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a -id test-id)))..
7ca0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
7cb0: 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e -run-ids-matchin
7cc0: 67 2d 74 61 72 67 65 74 20 6b 65 79 6e 61 6d 65 g-target keyname
7cd0: 73 20 74 61 72 67 65 74 20 72 65 73 20 72 75 6e s target res run
7ce0: 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 name testpatt st
7cf0: 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 atepatt statuspa
7d00: 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d tt). (rmt:send-
7d10: 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e receive 'get-run
7d20: 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 -ids-matching-ta
7d30: 72 67 65 74 20 23 66 20 28 6c 69 73 74 20 6b 65 rget #f (list ke
7d40: 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 ynames target re
7d50: 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 s runname testpa
7d60: 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 61 tt statepatt sta
7d70: 74 75 73 70 61 74 74 29 29 29 0a 0a 3b 3b 20 4e tuspatt)))..;; N
7d80: 4f 54 45 3a 20 54 68 69 73 20 77 69 6c 6c 20 6f OTE: This will o
7d90: 70 65 6e 20 61 6e 64 20 61 63 63 65 73 73 20 41 pen and access A
7da0: 4c 4c 20 72 75 6e 20 64 61 74 61 62 61 73 65 73 LL run databases
7db0: 2e 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 . .;;.(define (r
7dc0: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 68 mt:test-get-path
7dd0: 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 s-matching-keyna
7de0: 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b mes-target-new k
7df0: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
7e00: 65 73 20 74 65 73 74 70 61 74 74 20 73 74 61 74 es testpatt stat
7e10: 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 74 epatt statuspatt
7e20: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 runname). (let
7e30: 20 28 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a ((run-ids (rmt:
7e40: 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 get-run-ids-matc
7e50: 68 69 6e 67 2d 74 61 72 67 65 74 20 6b 65 79 6e hing-target keyn
7e60: 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 20 ames target res
7e70: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
7e80: 20 73 74 61 74 65 70 61 74 74 20 73 74 61 74 75 statepatt statu
7e90: 73 70 61 74 74 29 29 29 0a 20 20 20 20 28 61 70 spatt))). (ap
7ea0: 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 20 ply append ..
7eb0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 (map (lambda (ru
7ec0: 6e 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a 73 n-id)... (rmt:s
7ed0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
7ee0: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
7ef0: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
7f00: 72 67 65 74 2d 6e 65 77 20 72 75 6e 2d 69 64 20 rget-new run-id
7f10: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6b 65 79 (list run-id key
7f20: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
7f30: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 testpatt statep
7f40: 61 74 74 20 73 74 61 74 75 73 70 61 74 74 20 72 att statuspatt r
7f50: 75 6e 6e 61 6d 65 29 29 29 0a 09 20 20 20 72 75 unname))).. ru
7f60: 6e 2d 69 64 73 29 29 29 29 0a 0a 3b 3b 20 28 64 n-ids))))..;; (d
7f70: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
7f80: 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 20 un-ids-matching
7f90: 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 keynames target
7fa0: 72 65 73 29 0a 3b 3b 20 20 20 28 72 6d 74 3a 73 res).;; (rmt:s
7fb0: 65 6e 64 2d 72 65 63 65 69 76 65 20 23 66 20 27 end-receive #f '
7fc0: 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 get-run-ids-matc
7fd0: 68 69 6e 67 20 28 6c 69 73 74 20 6b 65 79 6e 61 hing (list keyna
7fe0: 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 29 29 mes target res))
7ff0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
8000: 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d get-prereqs-not-
8010: 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f met run-id waito
8020: 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e 61 6d 65 ns ref-test-name
8030: 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 ref-item-path #
8040: 21 6b 65 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 !key (mode '(nor
8050: 6d 61 6c 29 29 28 69 74 65 6d 6d 61 70 73 20 23 mal))(itemmaps #
8060: 66 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d f)). (rmt:send-
8070: 72 65 63 65 69 76 65 20 27 67 65 74 2d 70 72 65 receive 'get-pre
8080: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e reqs-not-met run
8090: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
80a0: 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 74 65 73 waitons ref-tes
80b0: 74 2d 6e 61 6d 65 20 72 65 66 2d 69 74 65 6d 2d t-name ref-item-
80c0: 70 61 74 68 20 6d 6f 64 65 20 69 74 65 6d 6d 61 path mode itemma
80d0: 70 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ps)))..(define (
80e0: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
80f0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
8100: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 0a 20 run-id run-id).
8110: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
8120: 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 ve 'get-count-te
8130: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
8140: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c run-id run-id (l
8150: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 ist run-id)))..(
8160: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
8170: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 2d 63 6e not-completed-cn
8180: 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 t run-id). (rmt
8190: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
81a0: 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 et-not-completed
81b0: 2d 63 6e 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 -cnt run-id (lis
81c0: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 0a 3b 3b t run-id)))...;;
81d0: 20 53 74 61 74 69 73 74 69 63 61 6c 20 71 75 65 Statistical que
81e0: 72 69 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 72 ries..(define (r
81f0: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
8200: 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 ts-running run-i
8210: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
8220: 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f 75 6e eceive 'get-coun
8230: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 t-tests-running
8240: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8250: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
8260: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
8270: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
8280: 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 -testname run-id
8290: 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d testname). (rm
82a0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
82b0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
82c0: 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 running-for-test
82d0: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 name run-id (lis
82e0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d t run-id testnam
82f0: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 e)))..(define (r
8300: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
8310: 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f ts-running-in-jo
8320: 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 6a 6f bgroup run-id jo
8330: 62 67 72 6f 75 70 29 0a 20 20 28 72 6d 74 3a 73 bgroup). (rmt:s
8340: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8350: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
8360: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
8370: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
8380: 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 29 29 29 n-id jobgroup)))
8390: 0a 0a 3b 3b 20 73 74 61 74 65 20 61 6e 64 20 73 ..;; state and s
83a0: 74 61 74 75 73 20 61 72 65 20 65 78 74 72 61 20 tatus are extra
83b0: 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 61 6c 6c hints not usuall
83c0: 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 63 61 y used in the ca
83d0: 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 64 65 lculation.;;.(de
83e0: 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 73 74 fine (rmt:set-st
83f0: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
8400: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
8410: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
8420: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 em-path state st
8430: 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 0a 20 20 atus comment).
8440: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
8450: 65 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 e 'set-state-sta
8460: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
8470: 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 28 6c 69 items run-id (li
8480: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e st run-id test-n
8490: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 ame item-path st
84a0: 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 ate status comme
84b0: 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nt)))..(define (
84c0: 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 rmt:set-state-st
84d0: 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 atus-and-roll-up
84e0: 2d 72 75 6e 20 72 75 6e 2d 69 64 20 73 74 61 74 -run run-id stat
84f0: 65 20 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 e status). (rmt
8500: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
8510: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
8520: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 6e 20 and-roll-up-run
8530: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8540: 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 -id state status
8550: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 )))...(define (r
8560: 6d 74 3a 75 70 64 61 74 65 2d 70 61 73 73 2d 66 mt:update-pass-f
8570: 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 ail-counts run-i
8580: 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 d test-name). (
8590: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
85a0: 20 27 75 70 64 61 74 65 2d 70 61 73 73 2d 66 61 'update-pass-fa
85b0: 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 il-counts run-id
85c0: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
85d0: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 29 29 name test-name))
85e0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
85f0: 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d op-test-set-per-
8600: 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 pf-counts run-id
8610: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 test-name). (r
8620: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8630: 27 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 'top-test-set-pe
8640: 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e 2d r-pf-counts run-
8650: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
8660: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 test-name)))..(d
8670: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
8680: 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e aw-run-stats run
8690: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
86a0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 61 -receive 'get-ra
86b0: 77 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d w-run-stats run-
86c0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 id (list run-id)
86d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
86e0: 3a 67 65 74 2d 74 65 73 74 2d 74 69 6d 65 73 20 :get-test-times
86f0: 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 29 0a runname target).
8700: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8710: 69 76 65 20 27 67 65 74 2d 74 65 73 74 2d 74 69 ive 'get-test-ti
8720: 6d 65 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e mes #f (list run
8730: 6e 61 6d 65 20 74 61 72 67 65 74 20 29 29 29 20 name target )))
8740: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
8750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 ==========.;; R
8790: 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U N S.;;=======
87a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
87d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
87e0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
87f0: 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 t-run-info run-i
8800: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
8810: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d eceive 'get-run-
8820: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c 69 73 info run-id (lis
8830: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
8840: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6e 75 fine (rmt:get-nu
8850: 6d 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 29 0a m-runs runpatt).
8860: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8870: 69 76 65 20 27 67 65 74 2d 6e 75 6d 2d 72 75 6e ive 'get-num-run
8880: 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 70 61 s #f (list runpa
8890: 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 tt)))..(define (
88a0: 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 63 6e 74 rmt:get-runs-cnt
88b0: 2d 62 79 2d 70 61 74 74 20 72 75 6e 70 61 74 74 -by-patt runpatt
88c0: 20 74 61 72 67 65 74 70 61 74 74 20 6b 65 79 73 targetpatt keys
88d0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
88e0: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 73 2d ceive 'get-runs-
88f0: 63 6e 74 2d 62 79 2d 70 61 74 74 20 23 66 20 28 cnt-by-patt #f (
8900: 6c 69 73 74 20 72 75 6e 70 61 74 74 20 20 74 61 list runpatt ta
8910: 72 67 65 74 70 61 74 74 20 6b 65 79 73 29 29 29 rgetpatt keys)))
8920: 0a 0a 3b 3b 20 55 73 65 20 74 68 65 20 73 70 65 ..;; Use the spe
8930: 63 69 61 6c 20 72 75 6e 2d 69 64 20 3d 3d 20 23 cial run-id == #
8940: 66 20 73 63 65 6e 61 72 69 6f 20 68 65 72 65 20 f scenario here
8950: 73 69 6e 63 65 20 74 68 65 72 65 20 69 73 20 6e since there is n
8960: 6f 20 72 75 6e 20 79 65 74 0a 28 64 65 66 69 6e o run yet.(defin
8970: 65 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d e (rmt:register-
8980: 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e run keyvals runn
8990: 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 ame state status
89a0: 20 75 73 65 72 20 63 6f 6e 74 6f 75 72 29 0a 20 user contour).
89b0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
89c0: 76 65 20 27 72 65 67 69 73 74 65 72 2d 72 75 6e ve 'register-run
89d0: 20 23 66 20 28 6c 69 73 74 20 6b 65 79 76 61 6c #f (list keyval
89e0: 73 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 s runname state
89f0: 73 74 61 74 75 73 20 75 73 65 72 20 63 6f 6e 74 status user cont
8a00: 6f 75 72 29 29 29 0a 20 20 20 20 0a 28 64 65 66 our))). .(def
8a10: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e ine (rmt:get-run
8a20: 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 75 -name-from-id ru
8a30: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
8a40: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 d-receive 'get-r
8a50: 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 un-name-from-id
8a60: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8a70: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
8a80: 28 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 (rmt:delete-run
8a90: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
8aa0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 6c end-receive 'del
8ab0: 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 20 28 ete-run run-id (
8ac0: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
8ad0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 (define (rmt:upd
8ae0: 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 ate-run-stats ru
8af0: 6e 2d 69 64 20 73 74 61 74 73 29 0a 20 20 28 72 n-id stats). (r
8b00: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8b10: 27 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 'update-run-stat
8b20: 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 s #f (list run-i
8b30: 64 20 73 74 61 74 73 29 29 29 0a 0a 28 64 65 66 d stats)))..(def
8b40: 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d ine (rmt:delete-
8b50: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
8b60: 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 72 6d 74 -records). (rmt
8b70: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 :send-receive 'd
8b80: 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 elete-old-delete
8b90: 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 23 d-test-records #
8ba0: 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 f '()))..(define
8bb0: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 72 (rmt:get-runs r
8bc0: 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 unpatt count off
8bd0: 73 65 74 20 6b 65 79 70 61 74 74 73 29 0a 20 20 set keypatts).
8be0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
8bf0: 65 20 27 67 65 74 2d 72 75 6e 73 20 23 66 20 28 e 'get-runs #f (
8c00: 6c 69 73 74 20 72 75 6e 70 61 74 74 20 63 6f 75 list runpatt cou
8c10: 6e 74 20 6f 66 66 73 65 74 20 6b 65 79 70 61 74 nt offset keypat
8c20: 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ts)))..(define (
8c30: 72 6d 74 3a 73 69 6d 70 6c 65 2d 67 65 74 2d 72 rmt:simple-get-r
8c40: 75 6e 73 20 72 75 6e 70 61 74 74 20 63 6f 75 6e uns runpatt coun
8c50: 74 20 6f 66 66 73 65 74 20 74 61 72 67 65 74 29 t offset target)
8c60: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
8c70: 65 69 76 65 20 27 73 69 6d 70 6c 65 2d 67 65 74 eive 'simple-get
8c80: 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 -runs #f (list r
8c90: 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 unpatt count off
8ca0: 73 65 74 20 74 61 72 67 65 74 29 29 29 0a 0a 28 set target)))..(
8cb0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
8cc0: 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 0a 20 20 28 all-run-ids). (
8cd0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
8ce0: 20 27 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 'get-all-run-id
8cf0: 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 s #f '()))..(def
8d00: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 ine (rmt:get-pre
8d10: 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 v-run-ids run-id
8d20: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8d30: 63 65 69 76 65 20 27 67 65 74 2d 70 72 65 76 2d ceive 'get-prev-
8d40: 72 75 6e 2d 69 64 73 20 23 66 20 28 6c 69 73 74 run-ids #f (list
8d50: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
8d60: 69 6e 65 20 28 72 6d 74 3a 6c 6f 63 6b 2f 75 6e ine (rmt:lock/un
8d70: 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d 69 64 20 lock-run run-id
8d80: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
8d90: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8da0: 63 65 69 76 65 20 27 6c 6f 63 6b 2f 75 6e 6c 6f ceive 'lock/unlo
8db0: 63 6b 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 20 ck-run #f (list
8dc0: 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
8dd0: 63 6b 20 75 73 65 72 29 29 29 0a 0a 3b 3b 20 73 ck user)))..;; s
8de0: 65 74 2f 67 65 74 20 73 74 61 74 75 73 0a 28 64 et/get status.(d
8df0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
8e00: 75 6e 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 un-status run-id
8e10: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8e20: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 ceive 'get-run-s
8e30: 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 tatus #f (list r
8e40: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
8e50: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 e (rmt:get-run-s
8e60: 74 61 74 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 tate run-id). (
8e70: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
8e80: 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 65 20 'get-run-state
8e90: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
8ea0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ))...(define (rm
8eb0: 74 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 t:set-run-status
8ec0: 20 72 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 run-id run-stat
8ed0: 75 73 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 us #!key (msg #f
8ee0: 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 )). (rmt:send-r
8ef0: 65 63 65 69 76 65 20 27 73 65 74 2d 72 75 6e 2d eceive 'set-run-
8f00: 73 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 status #f (list
8f10: 72 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 run-id run-statu
8f20: 73 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e s msg)))..(defin
8f30: 65 20 28 72 6d 74 3a 73 65 74 2d 72 75 6e 2d 73 e (rmt:set-run-s
8f40: 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d tate-status run-
8f50: 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 20 id state status
8f60: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8f70: 63 65 69 76 65 20 27 73 65 74 2d 72 75 6e 2d 73 ceive 'set-run-s
8f80: 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 28 tate-status #f (
8f90: 6c 69 73 74 20 72 75 6e 2d 69 64 20 73 74 61 74 list run-id stat
8fa0: 65 20 73 74 61 74 75 73 29 29 29 0a 0a 0a 28 64 e status)))...(d
8fb0: 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 61 74 efine (rmt:updat
8fc0: 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 e-run-event_time
8fd0: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
8fe0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 send-receive 'up
8ff0: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
9000: 69 6d 65 20 23 66 20 28 6c 69 73 74 20 72 75 6e ime #f (list run
9010: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
9020: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (rmt:get-runs-by
9030: 2d 70 61 74 74 20 20 6b 65 79 73 20 72 75 6e 6e -patt keys runn
9040: 61 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 amepatt targpatt
9050: 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 66 69 offset limit fi
9060: 65 6c 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 elds last-runs-u
9070: 70 64 61 74 65 20 20 23 21 6b 65 79 20 20 28 73 pdate #!key (s
9080: 6f 72 74 2d 6f 72 64 65 72 20 22 61 73 63 22 29 ort-order "asc")
9090: 29 20 3b 3b 20 66 69 65 6c 64 73 20 6f 66 20 23 ) ;; fields of #
90a0: 66 20 75 73 65 73 20 64 65 66 61 75 6c 74 0a 20 f uses default.
90b0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
90c0: 76 65 20 27 67 65 74 2d 72 75 6e 73 2d 62 79 2d ve 'get-runs-by-
90d0: 70 61 74 74 20 23 66 20 28 6c 69 73 74 20 6b 65 patt #f (list ke
90e0: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
90f0: 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c argpatt offset l
9100: 69 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 imit fields last
9110: 2d 72 75 6e 73 2d 75 70 64 61 74 65 20 73 6f 72 -runs-update sor
9120: 74 2d 6f 72 64 65 72 29 29 29 0a 0a 28 64 65 66 t-order)))..(def
9130: 69 6e 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e ine (rmt:find-an
9140: 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 d-mark-incomplet
9150: 65 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 e run-id ovr-dea
9160: 64 74 69 6d 65 29 0a 20 20 3b 3b 20 28 69 66 20 dtime). ;; (if
9170: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
9180: 65 20 27 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 e 'have-incomple
9190: 74 65 73 3f 20 72 75 6e 2d 69 64 20 28 6c 69 73 tes? run-id (lis
91a0: 74 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 t run-id ovr-dea
91b0: 64 74 69 6d 65 29 29 0a 20 20 28 72 6d 74 3a 73 dtime)). (rmt:s
91c0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6d 61 72 end-receive 'mar
91d0: 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e k-incomplete run
91e0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
91f0: 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 29 ovr-deadtime)))
9200: 20 3b 3b 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 ;; )..(define (
9210: 72 6d 74 3a 67 65 74 2d 6d 61 69 6e 2d 72 75 6e rmt:get-main-run
9220: 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 29 0a 20 -stats run-id).
9230: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
9240: 76 65 20 27 67 65 74 2d 6d 61 69 6e 2d 72 75 6e ve 'get-main-run
9250: 2d 73 74 61 74 73 20 23 66 20 28 6c 69 73 74 20 -stats #f (list
9260: 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 run-id)))..(defi
9270: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 ne (rmt:get-var
9280: 76 61 72 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a varname). (rmt:
9290: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
92a0: 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 t-var #f (list v
92b0: 61 72 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 arname)))..(defi
92c0: 6e 65 20 28 72 6d 74 3a 64 65 6c 2d 76 61 72 20 ne (rmt:del-var
92d0: 76 61 72 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a varname). (rmt:
92e0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 send-receive 'de
92f0: 6c 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 l-var #f (list v
9300: 61 72 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 arname)))..(defi
9310: 6e 65 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 ne (rmt:set-var
9320: 76 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 0a 20 varname value).
9330: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
9340: 76 65 20 27 73 65 74 2d 76 61 72 20 23 66 20 28 ve 'set-var #f (
9350: 6c 69 73 74 20 76 61 72 6e 61 6d 65 20 76 61 6c list varname val
9360: 75 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ue)))..;;=======
9370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
93b0: 3b 3b 20 4d 20 55 20 4c 20 54 20 49 20 52 20 55 ;; M U L T I R U
93c0: 20 4e 20 20 20 51 20 55 20 45 20 52 20 49 20 45 N Q U E R I E
93d0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
93e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
9420: 4e 65 65 64 20 74 6f 20 6d 6f 76 65 20 74 68 69 Need to move thi
9430: 73 20 74 6f 20 6d 75 6c 74 69 2d 72 75 6e 20 73 s to multi-run s
9440: 65 63 74 69 6f 6e 20 61 6e 64 20 6d 61 6b 65 20 ection and make
9450: 61 73 73 6f 63 69 61 74 65 64 20 63 68 61 6e 67 associated chang
9460: 65 73 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a es.(define (rmt:
9470: 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e find-and-mark-in
9480: 63 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e complete-all-run
9490: 73 20 23 21 6b 65 79 20 28 6f 76 72 2d 64 65 61 s #!key (ovr-dea
94a0: 64 74 69 6d 65 20 23 66 29 29 0a 20 20 28 6c 65 dtime #f)). (le
94b0: 74 20 28 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 t ((run-ids (rmt
94c0: 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 :get-all-run-ids
94d0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
94e0: 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 h (lambda (run-i
94f0: 64 29 0a 09 20 20 20 20 20 20 20 28 72 6d 74 3a d).. (rmt:
9500: 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e find-and-mark-in
9510: 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 complete run-id
9520: 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 0a 09 ovr-deadtime))..
9530: 20 20 20 20 20 72 75 6e 2d 69 64 73 29 29 29 0a run-ids))).
9540: 0a 3b 3b 20 67 65 74 20 74 68 65 20 70 72 65 76 .;; get the prev
9550: 69 6f 75 73 20 72 65 63 6f 72 64 20 66 6f 72 20 ious record for
9560: 77 68 65 6e 20 74 68 69 73 20 74 65 73 74 20 77 when this test w
9570: 61 73 20 72 75 6e 20 77 68 65 72 65 20 61 6c 6c as run where all
9580: 20 6b 65 79 73 20 6d 61 74 63 68 20 62 75 74 20 keys match but
9590: 72 75 6e 6e 61 6d 65 0a 3b 3b 20 72 65 74 75 72 runname.;; retur
95a0: 6e 73 20 23 66 20 69 66 20 6e 6f 20 73 75 63 68 ns #f if no such
95b0: 20 74 65 73 74 20 66 6f 75 6e 64 2c 20 72 65 74 test found, ret
95c0: 75 72 6e 73 20 61 20 73 69 6e 67 6c 65 20 74 65 urns a single te
95d0: 73 74 20 72 65 63 6f 72 64 20 69 66 20 66 6f 75 st record if fou
95e0: 6e 64 0a 3b 3b 20 0a 3b 3b 20 52 75 6e 20 74 68 nd.;; .;; Run th
95f0: 69 73 20 61 74 20 74 68 65 20 63 6c 69 65 6e 74 is at the client
9600: 20 65 6e 64 20 73 69 6e 63 65 20 77 65 20 68 61 end since we ha
9610: 76 65 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f ve to connect to
9620: 20 6d 75 6c 74 69 70 6c 65 20 72 75 6e 2d 69 64 multiple run-id
9630: 20 64 62 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 dbs.;;.(define
9640: 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 (rmt:get-previou
9650: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
9660: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
9670: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 me item-path).
9680: 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 (let* ((keyvals
9690: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c (rmt:get-key-val
96a0: 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 29 29 0a -pairs run-id)).
96b0: 09 20 28 6b 65 79 73 20 20 20 20 28 72 6d 74 3a . (keys (rmt:
96c0: 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 28 73 65 get-keys)).. (se
96d0: 6c 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e lstr (string-in
96e0: 74 65 72 73 70 65 72 73 65 20 20 6b 65 79 73 20 tersperse keys
96f0: 22 2c 22 29 29 0a 09 20 28 71 72 79 73 74 72 20 ",")).. (qrystr
9700: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
9710: 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 erse (map (lambd
9720: 61 20 28 78 29 28 63 6f 6e 63 20 78 20 22 3d 3f a (x)(conc x "=?
9730: 22 29 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 ")) keys) " AND
9740: 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f "))). (if (no
9750: 74 20 6b 65 79 76 61 6c 73 29 0a 09 23 66 0a 09 t keyvals)..#f..
9760: 28 6c 65 74 20 28 28 70 72 65 76 2d 72 75 6e 2d (let ((prev-run-
9770: 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 ids (rmt:get-pre
9780: 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 v-run-ids run-id
9790: 29 29 29 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 ))).. ;; for ea
97a0: 63 68 20 72 75 6e 20 73 74 61 72 74 69 6e 67 20 ch run starting
97b0: 77 69 74 68 20 74 68 65 20 6d 6f 73 74 20 72 65 with the most re
97c0: 63 65 6e 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 cent look to see
97d0: 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 6d if there is a m
97e0: 61 74 63 68 69 6e 67 20 74 65 73 74 0a 09 20 20 atching test..
97f0: 3b 3b 20 69 66 20 66 6f 75 6e 64 20 74 68 65 6e ;; if found then
9800: 20 72 65 74 75 72 6e 20 74 68 61 74 20 6d 61 74 return that mat
9810: 63 68 69 6e 67 20 74 65 73 74 20 72 65 63 6f 72 ching test recor
9820: 64 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e d.. (debug:prin
9830: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
9840: 2d 70 6f 72 74 2a 20 22 73 65 6c 73 74 72 3a 20 -port* "selstr:
9850: 22 20 73 65 6c 73 74 72 20 22 2c 20 71 72 79 73 " selstr ", qrys
9860: 74 72 3a 20 22 20 71 72 79 73 74 72 20 22 2c 20 tr: " qrystr ",
9870: 6b 65 79 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 keyvals: " keyva
9880: 6c 73 20 22 2c 20 70 72 65 76 69 6f 75 73 20 72 ls ", previous r
9890: 75 6e 20 69 64 73 20 66 6f 75 6e 64 3a 20 22 20 un ids found: "
98a0: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 0a 09 20 prev-run-ids)..
98b0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 72 65 76 (if (null? prev
98c0: 2d 72 75 6e 2d 69 64 73 29 20 23 66 0a 09 20 20 -run-ids) #f..
98d0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
98e0: 68 65 64 20 28 63 61 72 20 70 72 65 76 2d 72 75 hed (car prev-ru
98f0: 6e 2d 69 64 73 29 29 0a 09 09 09 20 28 74 61 6c n-ids)).... (tal
9900: 20 28 63 64 72 20 70 72 65 76 2d 72 75 6e 2d 69 (cdr prev-run-i
9910: 64 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 72 ds)))...(let ((r
9920: 65 73 75 6c 74 73 20 28 72 6d 74 3a 67 65 74 2d esults (rmt:get-
9930: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 68 65 tests-for-run he
9940: 64 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d d (conc test-nam
9950: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
9960: 20 27 28 29 20 27 28 29 20 3b 3b 20 72 75 6e 2d '() '() ;; run-
9970: 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 id testpatt stat
9980: 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 es statuses.....
9990: 09 09 20 20 20 20 20 20 23 66 20 23 66 20 23 66 .. #f #f #f
99a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
99b0: 3b 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 6e ; offset limit n
99c0: 6f 74 2d 69 6e 20 68 69 64 65 2f 6e 6f 74 2d 68 ot-in hide/not-h
99d0: 69 64 65 0a 09 09 09 09 09 09 20 20 20 20 20 20 ide.......
99e0: 23 66 20 23 66 20 23 66 20 23 66 20 27 6e 6f 72 #f #f #f #f 'nor
99f0: 6d 61 6c 29 29 29 20 3b 3b 20 73 6f 72 74 2d 62 mal))) ;; sort-b
9a00: 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 y sort-order qry
9a10: 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 65 vals last-update
9a20: 20 6d 6f 64 65 0a 09 09 20 20 28 64 65 62 75 67 mode... (debug
9a30: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
9a40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 47 6f 74 t-log-port* "Got
9a50: 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 tests for run-i
9a60: 64 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 d " run-id ", te
9a70: 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e st-name " test-n
9a80: 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 ame ", item-path
9a90: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a 20 " item-path ":
9aa0: 22 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 28 " results)... (
9ab0: 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 72 if (and (null? r
9ac0: 65 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 6e esults).... (n
9ad0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 ot (null? tal)))
9ae0: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
9af0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
9b00: 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 ))... (if (
9b10: 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 23 null? results) #
9b20: 66 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 75 f.... (car resu
9b30: 6c 74 73 29 29 29 29 29 29 29 29 29 29 0a 0a 28 lts))))))))))..(
9b40: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
9b50: 72 75 6e 2d 73 74 61 74 73 29 0a 20 20 28 72 6d run-stats). (rm
9b60: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
9b70: 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 get-run-stats #f
9b80: 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d '()))..;;======
9b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9bd0: 0a 3b 3b 20 20 53 20 54 20 45 20 50 20 53 0a 3b .;; S T E P S.;
9be0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
9bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c20: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 74 =======..;; Gett
9c30: 69 6e 67 20 73 74 65 70 73 20 69 73 20 6d 6f 72 ing steps is mor
9c40: 65 20 63 6f 6d 70 6c 69 63 61 74 65 64 2e 0a 3b e complicated..;
9c50: 3b 0a 3b 3b 20 49 66 20 67 69 76 65 6e 20 77 6f ;.;; If given wo
9c60: 72 6b 20 61 72 65 61 20 0a 3b 3b 20 20 31 2e 20 rk area .;; 1.
9c70: 46 69 6e 64 20 74 68 65 20 74 65 73 74 64 61 74 Find the testdat
9c80: 2e 64 62 20 66 69 6c 65 0a 3b 3b 20 20 32 2e 20 .db file.;; 2.
9c90: 4f 70 65 6e 20 74 68 65 20 74 65 73 74 64 61 74 Open the testdat
9ca0: 2e 64 62 20 66 69 6c 65 20 61 6e 64 20 64 6f 20 .db file and do
9cb0: 74 68 65 20 71 75 65 72 79 0a 3b 3b 20 49 66 20 the query.;; If
9cc0: 6e 6f 74 20 67 69 76 65 6e 20 74 68 65 20 77 6f not given the wo
9cd0: 72 6b 20 61 72 65 61 0a 3b 3b 20 20 31 2e 20 44 rk area.;; 1. D
9ce0: 6f 20 61 20 72 65 6d 6f 74 65 20 63 61 6c 6c 20 o a remote call
9cf0: 74 6f 20 67 65 74 20 74 68 65 20 74 65 73 74 20 to get the test
9d00: 70 61 74 68 0a 3b 3b 20 20 32 2e 20 43 6f 6e 74 path.;; 2. Cont
9d10: 69 6e 75 65 20 61 73 20 61 62 6f 76 65 0a 3b 3b inue as above.;;
9d20: 20 0a 3b 3b 28 64 65 66 69 6e 65 20 28 72 6d 74 .;;(define (rmt
9d30: 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 :get-steps-for-t
9d40: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
9d50: 69 64 29 0a 3b 3b 20 20 28 72 6d 74 3a 73 65 6e id).;; (rmt:sen
9d60: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 73 d-receive 'get-s
9d70: 74 65 70 73 2d 64 61 74 61 20 72 75 6e 2d 69 64 teps-data run-id
9d80: 20 28 6c 69 73 74 20 74 65 73 74 2d 69 64 29 29 (list test-id))
9d90: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
9da0: 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 61 teststep-set-sta
9db0: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
9dc0: 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 6d -id teststep-nam
9dd0: 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 75 e state-in statu
9de0: 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 s-in comment log
9df0: 66 69 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 file). (let* ((
9e00: 73 74 61 74 65 20 20 20 20 20 28 69 74 65 6d 73 state (items
9e10: 3a 63 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 :check-valid-ite
9e20: 6d 73 20 22 73 74 61 74 65 22 20 73 74 61 74 65 ms "state" state
9e30: 2d 69 6e 29 29 0a 09 20 28 73 74 61 74 75 73 20 -in)).. (status
9e40: 20 20 20 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d (items:check-
9e50: 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 61 valid-items "sta
9e60: 74 75 73 22 20 73 74 61 74 75 73 2d 69 6e 29 29 tus" status-in))
9e70: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e ). (if (or (n
9e80: 6f 74 20 73 74 61 74 65 29 28 6e 6f 74 20 73 74 ot state)(not st
9e90: 61 74 75 73 29 29 0a 09 28 64 65 62 75 67 3a 70 atus))..(debug:p
9ea0: 72 69 6e 74 20 33 20 2a 64 65 66 61 75 6c 74 2d rint 3 *default-
9eb0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
9ec0: 4e 47 3a 20 49 6e 76 61 6c 69 64 20 22 20 28 69 NG: Invalid " (i
9ed0: 66 20 73 74 61 74 75 73 20 22 73 74 61 74 75 73 f status "status
9ee0: 22 20 22 73 74 61 74 65 22 29 0a 09 09 20 20 20 " "state")...
9ef0: 20 20 22 20 76 61 6c 75 65 20 5c 22 22 20 28 69 " value \"" (i
9f00: 66 20 73 74 61 74 75 73 20 73 74 61 74 65 2d 69 f status state-i
9f10: 6e 20 73 74 61 74 75 73 2d 69 6e 29 20 22 5c 22 n status-in) "\"
9f20: 2c 20 75 70 64 61 74 65 20 79 6f 75 72 20 76 61 , update your va
9f30: 6c 69 64 76 61 6c 75 65 73 20 73 65 63 74 69 6f lidvalues sectio
9f40: 6e 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f n in megatest.co
9f50: 6e 66 69 67 22 29 29 0a 20 20 20 20 28 72 6d 74 nfig")). (rmt
9f60: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
9f70: 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 eststep-set-stat
9f80: 75 73 21 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 us! run-id (list
9f90: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
9fa0: 74 65 73 74 73 74 65 70 2d 6e 61 6d 65 20 73 74 teststep-name st
9fb0: 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e ate-in status-in
9fc0: 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 comment logfile
9fd0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
9fe0: 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 mt:get-steps-for
9ff0: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 -test run-id tes
a000: 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e t-id). (rmt:sen
a010: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 73 d-receive 'get-s
a020: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 teps-for-test ru
a030: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
a040: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 d test-id)))..(d
a050: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 efine (rmt:get-s
a060: 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 teps-info-by-id
a070: 74 65 73 74 2d 73 74 65 70 2d 69 64 29 0a 20 20 test-step-id).
a080: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
a090: 65 20 27 67 65 74 2d 73 74 65 70 73 2d 69 6e 66 e 'get-steps-inf
a0a0: 6f 2d 62 79 2d 69 64 20 23 66 20 28 6c 69 73 74 o-by-id #f (list
a0b0: 20 74 65 73 74 2d 73 74 65 70 2d 69 64 29 29 29 test-step-id)))
a0c0: 0a 0a 3b 3b 3d 3d 3d 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 0a 3b 3b 20 20 54 ==========.;; T
a110: 20 45 20 53 20 54 20 20 20 44 20 41 20 54 20 41 E S T D A T A
a120: 20 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
a170: 69 6e 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 ine (rmt:read-te
a180: 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 st-data run-id t
a190: 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 est-id categoryp
a1a0: 61 74 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d att #!key (work-
a1b0: 61 72 65 61 20 23 66 29 29 20 0a 20 20 28 72 6d area #f)) . (rm
a1c0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
a1d0: 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 20 72 read-test-data r
a1e0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
a1f0: 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 65 67 id test-id categ
a200: 6f 72 79 70 61 74 74 29 29 29 0a 28 64 65 66 69 orypatt))).(defi
a210: 6e 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 ne (rmt:read-tes
a220: 74 2d 64 61 74 61 2a 20 72 75 6e 2d 69 64 20 74 t-data* run-id t
a230: 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 est-id categoryp
a240: 61 74 74 20 76 61 72 70 61 74 74 20 23 21 6b 65 att varpatt #!ke
a250: 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 y (work-area #f)
a260: 29 20 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 ) . (rmt:send-r
a270: 65 63 65 69 76 65 20 27 72 65 61 64 2d 74 65 73 eceive 'read-tes
a280: 74 2d 64 61 74 61 2a 20 72 75 6e 2d 69 64 20 28 t-data* run-id (
a290: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
a2a0: 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 -id categorypatt
a2b0: 20 76 61 72 70 61 74 74 29 29 29 0a 0a 28 64 65 varpatt)))..(de
a2c0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 64 61 fine (rmt:get-da
a2d0: 74 61 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 74 65 ta-info-by-id te
a2e0: 73 74 2d 64 61 74 61 2d 69 64 29 0a 20 20 20 28 st-data-id). (
a2f0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
a300: 20 27 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d 'get-data-info-
a310: 62 79 2d 69 64 20 23 66 20 28 6c 69 73 74 20 74 by-id #f (list t
a320: 65 73 74 2d 64 61 74 61 2d 69 64 29 29 29 0a 0a est-data-id)))..
a330: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
a340: 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 tmeta-add-record
a350: 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d testname). (rm
a360: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
a370: 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 testmeta-add-rec
a380: 6f 72 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 ord #f (list tes
a390: 74 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e tname)))..(defin
a3a0: 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d e (rmt:testmeta-
a3b0: 67 65 74 2d 72 65 63 6f 72 64 20 74 65 73 74 6e get-record testn
a3c0: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
a3d0: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 6d 65 -receive 'testme
a3e0: 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 23 66 ta-get-record #f
a3f0: 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 29 (list testname)
a400: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
a410: 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 :testmeta-update
a420: 2d 66 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d 65 -field test-name
a430: 20 66 6c 64 20 76 61 6c 29 0a 20 20 28 72 6d 74 fld val). (rmt
a440: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
a450: 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 estmeta-update-f
a460: 69 65 6c 64 20 23 66 20 28 6c 69 73 74 20 74 65 ield #f (list te
a470: 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 st-name fld val)
a480: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
a490: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
a4a0: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
a4b0: 20 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 3a status). (rmt:
a4c0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
a4d0: 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 st-data-rollup r
a4e0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
a4f0: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 id test-id statu
a500: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 s)))..(define (r
a510: 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 mt:csv->test-dat
a520: 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 a run-id test-id
a530: 20 63 73 76 64 61 74 61 29 0a 20 20 28 72 6d 74 csvdata). (rmt
a540: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 63 :send-receive 'c
a550: 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 sv->test-data ru
a560: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
a570: 64 20 74 65 73 74 2d 69 64 20 63 73 76 64 61 74 d test-id csvdat
a580: 61 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d a)))..;;========
a590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
a5d0: 3b 20 20 54 20 41 20 53 20 4b 20 53 0a 3b 3b 3d ; T A S K S.;;=
a5e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a620: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
a630: 72 6d 74 3a 74 61 73 6b 73 2d 66 69 6e 64 2d 74 rmt:tasks-find-t
a640: 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 ask-queue-record
a650: 73 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d s target run-nam
a660: 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 61 74 e test-patt stat
a670: 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 e-patt action-pa
a680: 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d tt). (rmt:send-
a690: 72 65 63 65 69 76 65 20 27 66 69 6e 64 2d 74 61 receive 'find-ta
a6a0: 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 sk-queue-records
a6b0: 20 23 66 20 28 6c 69 73 74 20 74 61 72 67 65 74 #f (list target
a6c0: 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 run-name test-p
a6d0: 61 74 74 20 73 74 61 74 65 2d 70 61 74 74 20 61 att state-patt a
a6e0: 63 74 69 6f 6e 2d 70 61 74 74 29 29 29 0a 0a 28 ction-patt)))..(
a6f0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b define (rmt:task
a700: 73 2d 61 64 64 20 61 63 74 69 6f 6e 20 6f 77 6e s-add action own
a710: 65 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d er target runnam
a720: 65 20 74 65 73 74 70 61 74 74 20 70 61 72 61 6d e testpatt param
a730: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
a740: 65 63 65 69 76 65 20 27 74 61 73 6b 73 2d 61 64 eceive 'tasks-ad
a750: 64 20 23 66 20 28 6c 69 73 74 20 61 63 74 69 6f d #f (list actio
a760: 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 72 n owner target r
a770: 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 unname testpatt
a780: 70 61 72 61 6d 73 29 29 29 0a 0a 28 64 65 66 69 params)))..(defi
a790: 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 ne (rmt:tasks-se
a7a0: 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 t-state-given-pa
a7b0: 72 61 6d 2d 6b 65 79 20 70 61 72 61 6d 2d 6b 65 ram-key param-ke
a7c0: 79 20 6e 65 77 2d 73 74 61 74 65 29 0a 20 20 28 y new-state). (
a7d0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
a7e0: 20 27 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 'tasks-set-stat
a7f0: 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 e-given-param-ke
a800: 79 20 23 66 20 28 6c 69 73 74 20 20 70 61 72 61 y #f (list para
a810: 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 29 m-key new-state)
a820: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
a830: 3a 74 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 20 :tasks-get-last
a840: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 29 0a target runname).
a850: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
a860: 69 76 65 20 27 74 61 73 6b 73 2d 67 65 74 2d 6c ive 'tasks-get-l
a870: 61 73 74 20 23 66 20 28 6c 69 73 74 20 74 61 72 ast #f (list tar
a880: 67 65 74 20 72 75 6e 6e 61 6d 65 29 29 29 0a 0a get runname)))..
a890: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a8a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 4f 20 ========.;; N O
a8e0: 20 20 53 20 59 20 4e 20 43 20 20 20 44 20 42 20 S Y N C D B
a8f0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
a940: 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d ne (rmt:no-sync-
a950: 73 65 74 20 76 61 72 20 76 61 6c 29 0a 20 20 28 set var val). (
a960: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
a970: 20 27 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 23 66 'no-sync-set #f
a980: 20 60 28 2c 76 61 72 20 2c 76 61 6c 29 29 29 0a `(,var ,val))).
a990: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6e 6f .(define (rmt:no
a9a0: 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c -sync-get/defaul
a9b0: 74 20 76 61 72 20 64 65 66 61 75 6c 74 29 0a 20 t var default).
a9c0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
a9d0: 76 65 20 27 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f ve 'no-sync-get/
a9e0: 64 65 66 61 75 6c 74 20 23 66 20 60 28 2c 76 61 default #f `(,va
a9f0: 72 20 2c 64 65 66 61 75 6c 74 29 29 29 0a 0a 28 r ,default)))..(
aa00: 64 65 66 69 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 define (rmt:no-s
aa10: 79 6e 63 2d 64 65 6c 21 20 76 61 72 29 0a 20 20 ync-del! var).
aa20: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
aa30: 65 20 27 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 e 'no-sync-del!
aa40: 23 66 20 60 28 2c 76 61 72 29 29 29 0a 0a 28 64 #f `(,var)))..(d
aa50: 65 66 69 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 79 efine (rmt:no-sy
aa60: 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e nc-get-lock keyn
aa70: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
aa80: 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d 73 79 6e -receive 'no-syn
aa90: 63 2d 67 65 74 2d 6c 6f 63 6b 20 23 66 20 60 28 c-get-lock #f `(
aaa0: 2c 6b 65 79 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d ,keyname)))..;;=
aab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aaf0: 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 48 =====.;; A R C H
ab00: 20 49 20 56 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d I V E S.;;=====
ab10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab50: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
ab60: 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c 6f archive-get-allo
ab70: 63 61 74 69 6f 6e 73 20 20 74 65 73 74 6e 61 6d cations testnam
ab80: 65 20 69 74 65 6d 70 61 74 68 20 64 6e 65 65 64 e itempath dneed
ab90: 65 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ed). (rmt:send-
aba0: 72 65 63 65 69 76 65 20 27 61 72 63 68 69 76 65 receive 'archive
abb0: 2d 67 65 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e 73 -get-allocations
abc0: 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 6e 61 #f (list testna
abd0: 6d 65 20 69 74 65 6d 70 61 74 68 20 64 6e 65 65 me itempath dnee
abe0: 64 65 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ded)))..(define
abf0: 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 72 65 67 (rmt:archive-reg
ac00: 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 ister-block-name
ac10: 20 62 64 69 73 6b 2d 69 64 20 61 72 63 68 69 76 bdisk-id archiv
ac20: 65 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a 73 e-path). (rmt:s
ac30: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 72 63 end-receive 'arc
ac40: 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d 62 6c hive-register-bl
ac50: 6f 63 6b 2d 6e 61 6d 65 20 23 66 20 28 6c 69 73 ock-name #f (lis
ac60: 74 20 62 64 69 73 6b 2d 69 64 20 61 72 63 68 69 t bdisk-id archi
ac70: 76 65 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 ve-path)))..(def
ac80: 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 65 ine (rmt:archive
ac90: 2d 61 6c 6c 6f 63 61 74 65 2d 74 65 73 74 73 75 -allocate-testsu
aca0: 69 74 65 2f 61 72 65 61 2d 74 6f 2d 62 6c 6f 63 ite/area-to-bloc
acb0: 6b 20 62 6c 6f 63 6b 2d 69 64 20 74 65 73 74 73 k block-id tests
acc0: 75 69 74 65 2d 6e 61 6d 65 20 61 72 65 61 6b 65 uite-name areake
acd0: 79 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 y). (rmt:send-r
ace0: 65 63 65 69 76 65 20 27 61 72 63 68 69 76 65 2d eceive 'archive-
acf0: 61 6c 6c 6f 63 61 74 65 2d 74 65 73 74 2d 74 6f allocate-test-to
ad00: 2d 62 6c 6f 63 6b 20 23 66 20 28 6c 69 73 74 20 -block #f (list
ad10: 20 62 6c 6f 63 6b 2d 69 64 20 74 65 73 74 73 75 block-id testsu
ad20: 69 74 65 2d 6e 61 6d 65 20 61 72 65 61 6b 65 79 ite-name areakey
ad30: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
ad40: 74 3a 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 t:archive-regist
ad50: 65 72 2d 64 69 73 6b 20 62 64 69 73 6b 2d 6e 61 er-disk bdisk-na
ad60: 6d 65 20 62 64 69 73 6b 2d 70 61 74 68 20 64 66 me bdisk-path df
ad70: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
ad80: 63 65 69 76 65 20 27 61 72 63 68 69 76 65 2d 72 ceive 'archive-r
ad90: 65 67 69 73 74 65 72 2d 64 69 73 6b 20 23 66 20 egister-disk #f
ada0: 28 6c 69 73 74 20 62 64 69 73 6b 2d 6e 61 6d 65 (list bdisk-name
adb0: 20 62 64 69 73 6b 2d 70 61 74 68 20 64 66 29 29 bdisk-path df))
adc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
add0: 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 76 65 test-set-archive
ade0: 2d 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 -block-id run-id
adf0: 20 74 65 73 74 2d 69 64 20 61 72 63 68 69 76 65 test-id archive
ae00: 2d 62 6c 6f 63 6b 2d 69 64 29 0a 20 20 28 72 6d -block-id). (rm
ae10: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
ae20: 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 76 65 test-set-archive
ae30: 2d 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 -block-id run-id
ae40: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
ae50: 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c st-id archive-bl
ae60: 6f 63 6b 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 ock-id)))..(defi
ae70: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ne (rmt:test-get
ae80: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
ae90: 6e 66 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 nfo archive-bloc
aea0: 6b 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e k-id). (rmt:sen
aeb0: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
aec0: 67 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 get-archive-bloc
aed0: 6b 2d 69 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 k-info #f (list
aee0: 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 archive-block-id
aef0: 29 29 29 0a ))).