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 64 65 63 6c 61 72 65 20 port)).(declare
0420: 28 75 73 65 73 20 64 62 66 69 6c 65 29 29 0a 28 (uses dbfile)).(
0430: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0440: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 3b 3b records.scm").;;
0450: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
0460: 72 6d 74 6d 6f 64 29 29 0a 0a 28 69 6d 70 6f 72 rmtmod))..(impor
0470: 74 20 64 62 66 69 6c 65 29 20 3b 3b 20 72 6d 74 t dbfile) ;; rmt
0480: 6d 6f 64 29 0a 0a 3b 3b 0a 3b 3b 20 54 48 45 53 mod)..;;.;; THES
0490: 45 20 41 52 45 20 41 4c 4c 20 43 41 4c 4c 45 44 E ARE ALL CALLED
04a0: 20 4f 4e 20 54 48 45 20 43 4c 49 45 4e 54 20 53 ON THE CLIENT S
04b0: 49 44 45 21 21 21 0a 3b 3b 0a 0a 3b 3b 20 67 65 IDE!!!.;;..;; ge
04c0: 6e 65 72 61 74 65 20 65 6e 74 72 69 65 73 20 66 nerate entries f
04d0: 6f 72 20 7e 2f 2e 6d 65 67 61 74 65 73 74 72 63 or ~/.megatestrc
04e0: 20 77 69 74 68 20 74 68 65 20 66 6f 6c 6c 6f 77 with the follow
04f0: 69 6e 67 0a 3b 3b 0a 3b 3b 20 20 67 72 65 70 20 ing.;;.;; grep
0500: 64 65 66 69 6e 65 20 2e 2e 2f 72 6d 74 2e 73 63 define ../rmt.sc
0510: 6d 20 7c 20 67 72 65 70 20 72 6d 74 3a 20 7c 70 m | grep rmt: |p
0520: 65 72 6c 20 2d 70 69 20 2d 65 20 27 73 2f 5c 28 erl -pi -e 's/\(
0530: 64 65 66 69 6e 65 5c 73 2b 5c 28 28 5c 53 2b 29 define\s+\((\S+)
0540: 5c 57 2e 2a 24 2f 5c 31 2f 27 7c 73 6f 72 74 20 \W.*$/\1/'|sort
0550: 2d 75 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d -u..;;==========
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 ============.;;
05a0: 20 53 20 55 20 50 20 50 20 4f 20 52 20 54 20 20 S U P P O R T
05b0: 20 46 20 55 20 4e 20 43 20 54 20 49 20 4f 20 4e F U N C T I O N
05c0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
0610: 69 66 20 61 20 73 65 72 76 65 72 20 69 73 20 65 if a server is e
0620: 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 ither running or
0630: 20 69 6e 20 74 68 65 20 70 72 6f 63 65 73 73 20 in the process
0640: 6f 66 20 73 74 61 72 74 69 6e 67 20 63 61 6c 6c of starting call
0650: 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 0a 3b 3b client:setup.;;
0660: 20 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 20 else return #f
0670: 74 6f 20 6c 65 74 20 74 68 65 20 63 61 6c 6c 69 to let the calli
0680: 6e 67 20 70 72 6f 63 20 6b 6e 6f 77 20 74 68 61 ng proc know tha
0690: 74 20 74 68 65 72 65 20 69 73 20 6e 6f 20 73 65 t there is no se
06a0: 72 76 65 72 20 61 76 61 69 6c 61 62 6c 65 0a 3b rver available.;
06b0: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ;.(define (rmt:g
06c0: 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e et-connection-in
06d0: 66 6f 20 61 72 65 61 70 61 74 68 20 23 21 6b 65 fo areapath #!ke
06e0: 79 20 28 61 72 65 61 2d 64 61 74 20 23 66 29 29 y (area-dat #f))
06f0: 20 3b 3b 20 54 4f 44 4f 3a 20 70 75 73 68 20 61 ;; TODO: push a
0700: 72 65 61 70 61 74 68 20 64 6f 77 6e 2e 0a 20 20 reapath down..
0710: 28 6c 65 74 2a 20 28 28 72 75 6e 72 65 6d 6f 74 (let* ((runremot
0720: 65 20 28 6f 72 20 61 72 65 61 2d 64 61 74 20 2a e (or area-dat *
0730: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 09 20 28 runremote*)).. (
0740: 63 69 6e 66 6f 20 20 20 20 20 28 69 66 20 28 72 cinfo (if (r
0750: 65 6d 6f 74 65 3f 20 72 75 6e 72 65 6d 6f 74 65 emote? runremote
0760: 29 0a 09 09 09 28 72 65 6d 6f 74 65 2d 63 6f 6e )....(remote-con
0770: 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 0a ndat runremote).
0780: 09 09 09 23 66 29 29 29 0a 09 20 20 28 69 66 20 ...#f))).. (if
0790: 63 69 6e 66 6f 0a 09 20 20 20 20 20 20 63 69 6e cinfo.. cin
07a0: 66 6f 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 fo.. (if (s
07b0: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
07c0: 75 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 29 unning areapath)
07d0: 0a 09 09 20 20 28 63 6c 69 65 6e 74 3a 73 65 74 ... (client:set
07e0: 75 70 20 61 72 65 61 70 61 74 68 29 0a 09 09 20 up areapath)...
07f0: 20 23 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d #f))))..;;=====
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0840: 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 73 65 6e 64 =..(define *send
0850: 2d 72 65 63 65 69 76 65 2d 6d 75 74 65 78 2a 20 -receive-mutex*
0860: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 3b 3b (make-mutex)) ;;
0870: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 73 65 70 should have sep
0880: 61 72 61 74 65 20 6d 75 74 65 78 20 70 65 72 20 arate mutex per
0890: 72 75 6e 2d 69 64 0a 0a 3b 3b 20 52 41 20 3d 3e run-id..;; RA =>
08a0: 20 65 2e 67 2e 20 75 73 61 67 65 20 28 72 6d 74 e.g. usage (rmt
08b0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
08c0: 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 et-var #f (list
08d0: 76 61 72 6e 61 6d 65 29 29 0a 3b 3b 0a 28 64 65 varname)).;;.(de
08e0: 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e 64 2d 72 fine (rmt:send-r
08f0: 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 eceive cmd rid p
0900: 61 72 61 6d 73 20 23 21 6b 65 79 20 28 61 74 74 arams #!key (att
0910: 65 6d 70 74 6e 75 6d 20 31 29 28 61 72 65 61 2d emptnum 1)(area-
0920: 64 61 74 20 23 66 29 29 20 3b 3b 20 73 74 61 72 dat #f)) ;; star
0930: 74 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 74 20 t attemptnum at
0940: 31 20 73 6f 20 74 68 65 20 6d 6f 64 75 6c 6f 20 1 so the modulo
0950: 62 65 6c 6f 77 20 77 6f 72 6b 73 20 61 73 20 65 below works as e
0960: 78 70 65 63 74 65 64 0a 0a 20 20 23 3b 28 63 6f xpected.. #;(co
0970: 6d 6d 6f 6e 3a 74 65 6c 65 6d 65 74 72 79 2d 6c mmon:telemetry-l
0980: 6f 67 20 28 63 6f 6e 63 20 22 72 6d 74 3a 22 28 og (conc "rmt:"(
0990: 2d 3e 73 74 72 69 6e 67 20 63 6d 64 29 29 0a 20 ->string cmd)).
09a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09b0: 20 20 20 20 20 20 20 70 61 79 6c 6f 61 64 3a 20 payload:
09c0: 60 28 28 72 69 64 20 2e 20 2c 72 69 64 29 0a 20 `((rid . ,rid).
09d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09f0: 20 20 28 70 61 72 61 6d 73 20 2e 20 2c 70 61 72 (params . ,par
0a00: 61 6d 73 29 29 29 0a 0a 20 20 28 69 66 20 28 3e ams))).. (if (>
0a10: 20 61 74 74 65 6d 70 74 6e 75 6d 20 32 29 0a 20 attemptnum 2).
0a20: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0a30: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
0a40: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 61 74 -port* "INFO: at
0a50: 74 65 6d 70 74 6e 75 6d 20 69 6e 20 72 6d 74 3a temptnum in rmt:
0a60: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 69 73 20 send-receive is
0a70: 22 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 20 " attemptnum)).
0a80: 20 20 20 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 . (cond. (
0a90: 28 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 32 29 (> attemptnum 2)
0aa0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
0ab0: 30 2e 30 35 29 29 0a 20 20 20 28 28 3e 20 61 74 0.05)). ((> at
0ac0: 74 65 6d 70 74 6e 75 6d 20 31 30 29 20 28 74 68 temptnum 10) (th
0ad0: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 read-sleep! 0.5)
0ae0: 29 0a 20 20 20 28 28 3e 20 61 74 74 65 6d 70 74 ). ((> attempt
0af0: 6e 75 6d 20 32 30 29 20 28 74 68 72 65 61 64 2d num 20) (thread-
0b00: 73 6c 65 65 70 21 20 31 29 29 29 0a 20 20 28 69 sleep! 1))). (i
0b10: 66 20 28 61 6e 64 20 28 3e 20 61 74 74 65 6d 70 f (and (> attemp
0b20: 74 6e 75 6d 20 35 29 20 28 3d 20 30 20 28 6d 6f tnum 5) (= 0 (mo
0b30: 64 75 6c 6f 20 61 74 74 65 6d 70 74 6e 75 6d 20 dulo attemptnum
0b40: 31 35 29 29 29 20 20 0a 20 20 20 20 28 62 65 67 15))) . (beg
0b50: 69 6e 20 28 73 65 72 76 65 72 3a 72 75 6e 20 2a in (server:run *
0b60: 74 6f 70 70 61 74 68 2a 29 20 28 74 68 72 65 61 toppath*) (threa
0b70: 64 2d 73 6c 65 65 70 21 20 33 29 29 29 20 0a 20 d-sleep! 3))) .
0b80: 20 0a 20 20 0a 20 20 3b 3b 44 4f 54 20 64 69 67 . . ;;DOT dig
0b90: 72 61 70 68 20 6d 65 67 61 74 65 73 74 5f 73 74 raph megatest_st
0ba0: 61 74 65 5f 73 74 61 74 75 73 20 7b 0a 20 20 3b ate_status {. ;
0bb0: 3b 44 4f 54 20 20 20 72 61 6e 6b 73 65 70 3d 30 ;DOT ranksep=0
0bc0: 3b 0a 20 20 3b 3b 44 4f 54 20 20 20 2f 2f 20 72 ;. ;;DOT // r
0bd0: 61 6e 6b 64 69 72 3d 4c 52 3b 0a 20 20 3b 3b 44 ankdir=LR;. ;;D
0be0: 4f 54 20 20 20 6e 6f 64 65 20 5b 73 68 61 70 65 OT node [shape
0bf0: 3d 22 62 6f 78 22 5d 3b 0a 20 20 3b 3b 44 4f 54 ="box"];. ;;DOT
0c00: 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 "rmt:send-recei
0c10: 76 65 22 20 2d 3e 20 4d 55 54 45 58 4c 4f 43 4b ve" -> MUTEXLOCK
0c20: 3b 0a 20 20 3b 3b 44 4f 54 20 7b 20 65 64 67 65 ;. ;;DOT { edge
0c30: 20 5b 73 74 79 6c 65 3d 69 6e 76 69 73 5d 3b 22 [style=invis];"
0c40: 63 61 73 65 20 31 22 20 2d 3e 20 22 63 61 73 65 case 1" -> "case
0c50: 20 32 22 20 2d 3e 20 22 63 61 73 65 20 33 22 20 2" -> "case 3"
0c60: 2d 3e 20 22 63 61 73 65 20 34 22 20 2d 3e 20 22 -> "case 4" -> "
0c70: 63 61 73 65 20 35 22 20 2d 3e 20 22 63 61 73 65 case 5" -> "case
0c80: 20 36 22 20 2d 3e 20 22 63 61 73 65 20 37 22 20 6" -> "case 7"
0c90: 2d 3e 20 22 63 61 73 65 20 38 22 20 2d 3e 20 22 -> "case 8" -> "
0ca0: 63 61 73 65 20 39 22 20 2d 3e 20 22 63 61 73 65 case 9" -> "case
0cb0: 20 31 30 22 20 2d 3e 20 22 63 61 73 65 20 31 31 10" -> "case 11
0cc0: 22 3b 20 7d 0a 20 20 3b 3b 20 64 6f 20 61 6c 6c "; }. ;; do all
0cd0: 20 74 68 65 20 70 72 65 70 20 6c 6f 63 6b 65 64 the prep locked
0ce0: 20 75 6e 64 65 72 20 74 68 65 20 72 6d 74 2d 6d under the rmt-m
0cf0: 75 74 65 78 0a 20 20 28 6d 75 74 65 78 2d 6c 6f utex. (mutex-lo
0d00: 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 ck! *rmt-mutex*)
0d10: 0a 20 20 0a 20 20 3b 3b 20 31 2e 20 63 68 65 63 . . ;; 1. chec
0d20: 6b 20 69 66 20 73 65 72 76 65 72 20 69 73 20 73 k if server is s
0d30: 74 61 72 74 65 64 20 49 46 46 20 63 6d 64 20 69 tarted IFF cmd i
0d40: 73 20 61 20 77 72 69 74 65 20 4f 52 20 69 66 20 s a write OR if
0d50: 77 65 20 61 72 65 20 6e 6f 74 20 6f 6e 20 74 68 we are not on th
0d60: 65 20 68 6f 6d 65 68 6f 73 74 2c 20 73 74 6f 72 e homehost, stor
0d70: 65 20 69 6e 20 72 75 6e 72 65 6d 6f 74 65 0a 20 e in runremote.
0d80: 20 3b 3b 20 32 2e 20 63 68 65 63 6b 20 74 68 65 ;; 2. check the
0d90: 20 61 67 65 20 6f 66 20 74 68 65 20 63 6f 6e 6e age of the conn
0da0: 65 63 74 69 6f 6e 73 2e 20 72 65 66 72 65 73 68 ections. refresh
0db0: 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 the connection
0dc0: 69 66 20 69 74 20 69 73 20 6f 6c 64 65 72 20 74 if it is older t
0dd0: 68 61 6e 20 74 69 6d 65 6f 75 74 2d 32 30 20 73 han timeout-20 s
0de0: 65 63 6f 6e 64 73 2e 0a 20 20 3b 3b 20 33 2e 20 econds.. ;; 3.
0df0: 64 6f 20 74 68 65 20 71 75 65 72 79 2c 20 69 66 do the query, if
0e00: 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 75 73 65 on homehost use
0e10: 20 6c 6f 63 61 6c 20 61 63 63 65 73 73 0a 20 20 local access.
0e20: 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 ;;. (let* ((sta
0e30: 72 74 2d 74 69 6d 65 20 20 20 20 28 63 75 72 72 rt-time (curr
0e40: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b ent-seconds)) ;;
0e50: 20 73 6e 61 70 73 68 6f 74 20 74 69 6d 65 20 73 snapshot time s
0e60: 6f 20 61 6c 6c 20 75 73 65 20 63 61 73 65 73 20 o all use cases
0e70: 67 65 74 20 73 61 6d 65 20 76 61 6c 75 65 0a 20 get same value.
0e80: 20 20 20 20 20 20 20 20 28 61 72 65 61 70 61 74 (areapat
0e90: 68 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 2a h *toppath*
0ea0: 29 3b 3b 20 54 4f 44 4f 20 2d 20 72 65 73 6f 6c );; TODO - resol
0eb0: 76 65 20 66 72 6f 6d 20 64 62 73 74 72 75 63 74 ve from dbstruct
0ec0: 20 74 6f 20 62 65 20 63 6f 6d 70 61 74 69 62 6c to be compatibl
0ed0: 65 20 77 69 74 68 20 6d 75 6c 74 69 70 6c 65 20 e with multiple
0ee0: 61 72 65 61 73 0a 09 20 28 72 75 6e 72 65 6d 6f areas.. (runremo
0ef0: 74 65 20 20 20 20 20 28 6f 72 20 61 72 65 61 2d te (or area-
0f00: 64 61 74 0a 09 09 09 20 20 20 20 2a 72 75 6e 72 dat.... *runr
0f10: 65 6d 6f 74 65 2a 29 29 0a 20 20 20 20 20 20 20 emote*)).
0f20: 20 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 20 20 (attemptnum
0f30: 20 28 2b 20 31 20 61 74 74 65 6d 70 74 6e 75 6d (+ 1 attemptnum
0f40: 29 29 0a 09 20 28 72 65 61 64 6f 6e 6c 79 2d 6d )).. (readonly-m
0f50: 6f 64 65 20 28 72 6d 74 6d 6f 64 3a 63 61 6c 63 ode (rmtmod:calc
0f60: 2d 72 6f 2d 6d 6f 64 65 20 72 75 6e 72 65 6d 6f -ro-mode runremo
0f70: 74 65 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 0a te *toppath*))).
0f80: 0a 20 20 20 20 3b 3b 20 44 4f 54 20 49 4e 49 54 . ;; DOT INIT
0f90: 5f 52 55 4e 52 45 4d 4f 54 45 3b 20 2f 2f 20 6c _RUNREMOTE; // l
0fa0: 65 61 76 69 6e 67 20 6f 66 66 20 2d 20 64 6f 65 eaving off - doe
0fb0: 73 6e 27 74 20 72 65 61 6c 6c 79 20 61 64 64 20 sn't really add
0fc0: 74 6f 20 74 68 65 20 63 6c 61 72 69 74 79 0a 20 to the clarity.
0fd0: 20 20 20 3b 3b 20 44 4f 54 20 4d 55 54 45 58 4c ;; DOT MUTEXL
0fe0: 4f 43 4b 20 2d 3e 20 49 4e 49 54 5f 52 55 4e 52 OCK -> INIT_RUNR
0ff0: 45 4d 4f 54 45 20 5b 6c 61 62 65 6c 3d 22 6e 6f EMOTE [label="no
1000: 20 72 65 6d 6f 74 65 3f 22 5d 3b 0a 20 20 20 20 remote?"];.
1010: 3b 3b 20 44 4f 54 20 49 4e 49 54 5f 52 55 4e 52 ;; DOT INIT_RUNR
1020: 45 4d 4f 54 45 20 2d 3e 20 4d 55 54 45 58 4c 4f EMOTE -> MUTEXLO
1030: 43 4b 3b 0a 20 20 20 20 3b 3b 20 65 6e 73 75 72 CK;. ;; ensur
1040: 65 20 77 65 20 68 61 76 65 20 61 20 72 65 63 6f e we have a reco
1050: 72 64 20 66 6f 72 20 6f 75 72 20 63 6f 6e 6e 65 rd for our conne
1060: 63 74 69 6f 6e 20 66 6f 72 20 67 69 76 65 6e 20 ction for given
1070: 61 72 65 61 0a 20 20 20 20 28 69 66 20 28 6e 6f area. (if (no
1080: 74 20 72 75 6e 72 65 6d 6f 74 65 29 20 20 20 20 t runremote)
1090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
10a0: 3b 20 63 61 6e 20 72 65 6d 6f 76 65 20 74 68 69 ; can remove thi
10b0: 73 20 6f 6e 65 2e 20 73 68 6f 75 6c 64 20 6e 65 s one. should ne
10c0: 76 65 72 20 67 65 74 20 68 65 72 65 2e 20 20 20 ver get here.
10d0: 20 20 20 20 20 20 0a 09 28 62 65 67 69 6e 0a 09 ..(begin..
10e0: 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f (set! *runremo
10f0: 74 65 2a 20 28 6d 61 6b 65 2d 72 65 6d 6f 74 65 te* (make-remote
1100: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 )). (le
1110: 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e 66 6f t* ((server-info
1120: 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
1130: 69 6e 66 6f 20 2a 72 75 6e 72 65 6d 6f 74 65 2a info *runremote*
1140: 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ))) .
1150: 20 28 69 66 20 73 65 72 76 65 72 2d 69 6e 66 6f (if server-info
1160: 0a 09 09 28 62 65 67 69 6e 0a 09 09 09 28 72 65 ...(begin....(re
1170: 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d mote-server-url-
1180: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
1190: 20 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d (server:record-
11a0: 3e 75 72 6c 20 73 65 72 76 65 72 2d 69 6e 66 6f >url server-info
11b0: 29 29 0a 09 09 09 28 72 65 6d 6f 74 65 2d 73 65 ))....(remote-se
11c0: 72 76 65 72 2d 69 64 2d 73 65 74 21 20 2a 72 75 rver-id-set! *ru
11d0: 6e 72 65 6d 6f 74 65 2a 20 28 73 65 72 76 65 72 nremote* (server
11e0: 3a 72 65 63 6f 72 64 2d 3e 69 64 20 73 65 72 76 :record->id serv
11f0: 65 72 2d 69 6e 66 6f 29 29 29 29 29 20 20 0a 09 er-info))))) ..
1200: 20 20 28 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 (set! runremot
1210: 65 20 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 e *runremote*)
1220: 29 29 20 3b 3b 20 6e 65 77 20 72 75 6e 72 65 6d )) ;; new runrem
1230: 6f 74 65 20 77 69 6c 6c 20 63 6f 6d 65 20 66 72 ote will come fr
1240: 6f 6d 20 74 68 69 73 20 6f 6e 20 6e 65 78 74 20 om this on next
1250: 69 74 65 72 61 74 69 6f 6e 0a 20 20 20 20 0a 20 iteration. .
1260: 20 20 20 3b 3b 20 44 4f 54 20 53 45 54 5f 48 4f ;; DOT SET_HO
1270: 4d 45 48 4f 53 54 3b 20 2f 2f 20 6c 65 61 76 69 MEHOST; // leavi
1280: 6e 67 20 6f 66 66 20 2d 20 64 6f 65 73 6e 27 74 ng off - doesn't
1290: 20 72 65 61 6c 6c 79 20 61 64 64 20 74 6f 20 74 really add to t
12a0: 68 65 20 63 6c 61 72 69 74 79 0a 20 20 20 20 3b he clarity. ;
12b0: 3b 20 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 ; DOT MUTEXLOCK
12c0: 2d 3e 20 53 45 54 5f 48 4f 4d 45 48 4f 53 54 20 -> SET_HOMEHOST
12d0: 5b 6c 61 62 65 6c 3d 22 6e 6f 20 68 6f 6d 65 68 [label="no homeh
12e0: 6f 73 74 3f 22 5d 3b 0a 20 20 20 20 3b 3b 20 44 ost?"];. ;; D
12f0: 4f 54 20 53 45 54 5f 48 4f 4d 45 48 4f 53 54 20 OT SET_HOMEHOST
1300: 2d 3e 20 4d 55 54 45 58 4c 4f 43 4b 3b 0a 20 20 -> MUTEXLOCK;.
1310: 20 20 3b 3b 20 65 6e 73 75 72 65 20 77 65 20 68 ;; ensure we h
1320: 61 76 65 20 61 20 68 6f 6d 65 68 6f 73 74 20 72 ave a homehost r
1330: 65 63 6f 72 64 0a 20 20 20 20 28 69 66 20 28 6e ecord. (if (n
1340: 6f 74 20 28 70 61 69 72 3f 20 28 72 65 6d 6f 74 ot (pair? (remot
1350: 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f e-hh-dat runremo
1360: 74 65 29 29 29 20 20 3b 3b 20 6e 6f 74 20 6f 6e te))) ;; not on
1370: 20 68 6f 6d 65 68 6f 73 74 0a 09 28 74 68 72 65 homehost..(thre
1380: 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 20 3b ad-sleep! 0.1) ;
1390: 3b 20 73 69 6e 63 65 20 77 65 20 73 68 6f 75 6c ; since we shoul
13a0: 64 6e 27 74 20 67 65 74 20 68 65 72 65 2c 20 64 dn't get here, d
13b0: 65 6c 61 79 20 61 20 6c 69 74 74 6c 65 0a 09 28 elay a little..(
13c0: 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 2d 73 65 remote-hh-dat-se
13d0: 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 73 65 t! runremote (se
13e0: 72 76 65 72 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 rver:get-homehos
13f0: 74 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b t))). . ;;
1400: 28 70 72 69 6e 74 20 22 42 42 3e 20 72 65 61 64 (print "BB> read
1410: 6f 6e 6c 79 2d 6d 6f 64 65 20 69 73 20 22 72 65 only-mode is "re
1420: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 22 20 64 62 66 adonly-mode" dbf
1430: 69 6c 65 20 69 73 20 22 64 62 66 69 6c 65 29 0a ile is "dbfile).
1440: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 23 (cond. #
1450: 3b 28 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 ;((> (- (current
1460: 2d 73 65 63 6f 6e 64 73 29 28 72 65 6d 6f 74 65 -seconds)(remote
1470: 2d 63 6f 6e 6e 65 63 74 2d 74 69 6d 65 20 72 75 -connect-time ru
1480: 6e 72 65 6d 6f 74 65 29 29 20 31 38 30 29 20 3b nremote)) 180) ;
1490: 3b 20 72 65 63 6f 6e 6e 65 63 74 20 74 6f 20 73 ; reconnect to s
14a0: 65 72 76 65 72 20 65 76 65 72 79 20 31 38 30 20 erver every 180
14b0: 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 28 64 seconds. (d
14c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
14d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
14e0: 22 46 6f 72 63 69 6e 67 20 72 65 63 6f 6e 6e 65 "Forcing reconne
14f0: 63 74 20 74 6f 20 73 65 72 76 65 72 28 73 29 20 ct to server(s)
1500: 64 75 65 20 74 6f 20 31 38 30 20 73 65 63 6f 6e due to 180 secon
1510: 64 20 74 69 6d 65 6f 75 74 2e 22 29 0a 20 20 20 d timeout.").
1520: 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d (set! *runrem
1530: 6f 74 65 2a 20 23 66 29 0a 20 20 20 20 20 20 3b ote* #f). ;
1540: 3b 20 42 55 47 3a 20 63 6c 6f 73 65 2d 63 6f 6e ; BUG: close-con
1550: 6e 65 63 74 69 6f 6e 73 20 73 68 6f 75 6c 64 20 nections should
1560: 67 6f 20 68 65 72 65 3f 0a 20 20 20 20 20 20 28 go here?. (
1570: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 mutex-unlock! *r
1580: 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 mt-mutex*).
1590: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
15a0: 76 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d ve cmd rid param
15b0: 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 31 20 s attemptnum: 1
15c0: 61 72 65 61 2d 64 61 74 3a 20 61 72 65 61 2d 64 area-dat: area-d
15d0: 61 74 29 29 0a 20 20 20 20 20 0a 20 20 20 20 20 at)). .
15e0: 3b 3b 44 4f 54 20 45 58 49 54 3b 0a 20 20 20 20 ;;DOT EXIT;.
15f0: 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b ;;DOT MUTEXLOCK
1600: 20 2d 3e 20 45 58 49 54 20 5b 6c 61 62 65 6c 3d -> EXIT [label=
1610: 22 3e 20 31 35 20 61 74 74 65 6d 70 74 73 22 5d "> 15 attempts"]
1620: 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 ; {rank=same "ca
1630: 73 65 20 31 22 20 22 45 58 49 54 22 20 7d 0a 20 se 1" "EXIT" }.
1640: 20 20 20 20 3b 3b 20 67 69 76 65 20 75 70 20 69 ;; give up i
1650: 66 20 6d 6f 72 65 20 74 68 61 6e 20 31 35 30 20 f more than 150
1660: 61 74 74 65 6d 70 74 73 0a 20 20 20 20 20 28 28 attempts. ((
1670: 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 35 30 > attemptnum 150
1680: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
1690: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
16a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
16b0: 3a 20 31 35 30 20 74 72 69 65 73 20 74 6f 20 73 : 150 tries to s
16c0: 74 61 72 74 2f 63 6f 6e 6e 65 63 74 20 74 6f 20 tart/connect to
16d0: 73 65 72 76 65 72 2e 20 47 69 76 69 6e 67 20 75 server. Giving u
16e0: 70 2e 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 p."). (exit
16f0: 20 31 29 29 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 1)).. ;;DOT
1700: 20 43 41 53 45 32 20 5b 6c 61 62 65 6c 3d 22 6c CASE2 [label="l
1710: 6f 63 61 6c 5c 6e 72 65 61 64 6f 6e 6c 79 5c 6e ocal\nreadonly\n
1720: 71 75 65 72 79 22 5d 3b 0a 20 20 20 20 20 3b 3b query"];. ;;
1730: 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e DOT MUTEXLOCK ->
1740: 20 43 41 53 45 32 3b 20 7b 72 61 6e 6b 3d 73 61 CASE2; {rank=sa
1750: 6d 65 20 22 63 61 73 65 20 32 22 20 43 41 53 45 me "case 2" CASE
1760: 32 7d 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 2}. ;;DOT CA
1770: 53 45 32 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e SE2 -> "rmt:open
1780: 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c -qry-close-local
1790: 6c 79 22 3b 0a 20 20 20 20 20 3b 3b 20 72 65 61 ly";. ;; rea
17a0: 64 6f 6e 6c 79 20 6d 6f 64 65 2c 20 72 65 61 64 donly mode, read
17b0: 20 72 65 71 75 65 73 74 2d 20 20 68 61 6e 64 6c request- handl
17c0: 65 20 69 74 20 2d 20 63 61 73 65 20 32 0a 20 20 e it - case 2.
17d0: 20 20 20 28 28 61 6e 64 20 72 65 61 64 6f 6e 6c ((and readonl
17e0: 79 2d 6d 6f 64 65 0a 20 20 20 20 20 20 20 20 20 y-mode.
17f0: 20 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 (member cmd ap
1800: 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 i:read-only-quer
1810: 69 65 73 29 29 20 0a 20 20 20 20 20 20 28 6d 75 ies)) . (mu
1820: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
1830: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
1840: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1850: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
1860: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
1870: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 32 -receive, case 2
1880: 22 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 "). (rmt:op
1890: 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 en-qry-close-loc
18a0: 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d ally cmd 0 param
18b0: 73 29 0a 20 20 20 20 20 20 29 0a 0a 20 20 20 20 s). )..
18c0: 20 3b 3b 44 4f 54 20 43 41 53 45 33 20 5b 6c 61 ;;DOT CASE3 [la
18d0: 62 65 6c 3d 22 77 72 69 74 65 20 69 6e 5c 6e 72 bel="write in\nr
18e0: 65 61 64 2d 6f 6e 6c 79 20 6d 6f 64 65 22 5d 3b ead-only mode"];
18f0: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 . ;;DOT MUTE
1900: 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 33 20 5b XLOCK -> CASE3 [
1910: 6c 61 62 65 6c 3d 22 72 65 61 64 6f 6e 6c 79 5c label="readonly\
1920: 6e 6d 6f 64 65 3f 22 5d 3b 20 7b 72 61 6e 6b 3d nmode?"]; {rank=
1930: 73 61 6d 65 20 22 63 61 73 65 20 33 22 20 43 41 same "case 3" CA
1940: 53 45 33 7d 0a 20 20 20 20 20 3b 3b 44 4f 54 20 SE3}. ;;DOT
1950: 43 41 53 45 33 20 2d 3e 20 22 23 66 22 3b 0a 20 CASE3 -> "#f";.
1960: 20 20 20 20 3b 3b 20 72 65 61 64 6f 6e 6c 79 20 ;; readonly
1970: 6d 6f 64 65 2c 20 77 72 69 74 65 20 72 65 71 75 mode, write requ
1980: 65 73 74 2e 20 20 44 6f 20 6e 6f 74 68 69 6e 67 est. Do nothing
1990: 2c 20 72 65 74 75 72 6e 20 23 66 0a 20 20 20 20 , return #f.
19a0: 20 28 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 (readonly-mode
19b0: 28 65 78 74 72 61 73 2d 72 65 61 64 6f 6e 6c 79 (extras-readonly
19c0: 2d 6d 6f 64 65 20 2a 72 6d 74 2d 6d 75 74 65 78 -mode *rmt-mutex
19d0: 2a 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 * *default-log-p
19e0: 6f 72 74 2a 20 63 6d 64 20 70 61 72 61 6d 73 29 ort* cmd params)
19f0: 29 0a 0a 20 20 20 20 20 3b 3b 20 54 68 69 73 20 ).. ;; This
1a00: 62 6c 6f 63 6b 20 77 61 73 20 66 6f 72 20 70 72 block was for pr
1a10: 65 2d 65 6d 70 74 69 76 65 6c 79 20 72 65 73 65 e-emptively rese
1a20: 74 74 69 6e 67 20 74 68 65 20 63 6f 6e 6e 65 63 tting the connec
1a30: 74 69 6f 6e 20 69 66 20 74 68 65 72 65 20 68 61 tion if there ha
1a40: 64 20 62 65 65 6e 20 6e 6f 20 63 6f 6d 6d 75 6e d been no commun
1a50: 69 63 61 74 69 6f 6e 20 66 6f 72 20 73 6f 6d 65 ication for some
1a60: 20 74 69 6d 65 2e 0a 20 20 20 20 20 3b 3b 20 49 time.. ;; I
1a70: 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 69 74 20 don't think it
1a80: 61 64 64 73 20 61 6e 79 20 76 61 6c 75 65 2e 20 adds any value.
1a90: 49 66 20 74 68 65 20 73 65 72 76 65 72 20 69 73 If the server is
1aa0: 20 6e 6f 74 20 74 68 65 72 65 2c 20 6a 75 73 74 not there, just
1ab0: 20 66 61 69 6c 20 61 6e 64 20 73 74 61 72 74 20 fail and start
1ac0: 61 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 6f 6e a new connection
1ad0: 2e 0a 20 20 20 20 20 3b 3b 20 61 6c 73 6f 2c 20 .. ;; also,
1ae0: 74 68 65 20 65 78 70 69 72 65 2d 74 69 6d 65 20 the expire-time
1af0: 63 61 6c 63 75 6c 61 74 69 6f 6e 20 6d 69 67 68 calculation migh
1b00: 74 20 6e 6f 74 20 62 65 20 63 6f 72 72 65 63 74 t not be correct
1b10: 2e 20 57 65 20 77 61 6e 74 2c 20 74 69 6d 65 2d . We want, time-
1b20: 73 69 6e 63 65 2d 6c 61 73 74 2d 73 65 72 76 65 since-last-serve
1b30: 72 2d 61 63 63 65 73 73 20 3e 20 28 73 65 72 76 r-access > (serv
1b40: 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 0a er:get-timeout).
1b50: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 3b 3b 44 ;;. ;;D
1b60: 4f 54 20 43 41 53 45 34 20 5b 6c 61 62 65 6c 3d OT CASE4 [label=
1b70: 22 72 65 73 65 74 5c 6e 63 6f 6e 6e 65 63 74 69 "reset\nconnecti
1b80: 6f 6e 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 on"];. ;;DOT
1b90: 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 MUTEXLOCK -> CA
1ba0: 53 45 34 20 5b 6c 61 62 65 6c 3d 22 68 61 76 65 SE4 [label="have
1bb0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2c 5c 6e 6c 61 connection,\nla
1bc0: 73 74 5f 61 63 63 65 73 73 20 3e 20 65 78 70 69 st_access > expi
1bd0: 72 65 5f 74 69 6d 65 22 5d 3b 20 7b 72 61 6e 6b re_time"]; {rank
1be0: 3d 73 61 6d 65 20 22 63 61 73 65 20 34 22 20 43 =same "case 4" C
1bf0: 41 53 45 34 7d 0a 20 20 20 20 20 3b 3b 44 4f 54 ASE4}. ;;DOT
1c00: 20 43 41 53 45 34 20 2d 3e 20 22 72 6d 74 3a 73 CASE4 -> "rmt:s
1c10: 65 6e 64 2d 72 65 63 65 69 76 65 22 3b 0a 20 20 end-receive";.
1c20: 20 20 20 3b 3b 20 72 65 73 65 74 20 74 68 65 20 ;; reset the
1c30: 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 69 74 connection if it
1c40: 20 68 61 73 20 62 65 65 6e 20 75 6e 75 73 65 64 has been unused
1c50: 20 74 6f 6f 20 6c 6f 6e 67 0a 20 20 20 20 20 28 too long. (
1c60: 28 61 6e 64 20 72 75 6e 72 65 6d 6f 74 65 0a 20 (and runremote.
1c70: 20 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 (remot
1c80: 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d e-conndat runrem
1c90: 6f 74 65 29 0a 09 20 20 20 28 3e 20 28 63 75 72 ote).. (> (cur
1ca0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 3b 3b rent-seconds) ;;
1cb0: 20 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 if it has been
1cc0: 6d 6f 72 65 20 74 68 61 6e 20 73 65 72 76 65 72 more than server
1cd0: 2d 74 69 6d 65 6f 75 74 20 73 65 63 6f 6e 64 73 -timeout seconds
1ce0: 20 73 69 6e 63 65 20 6c 61 73 74 20 63 6f 6e 74 since last cont
1cf0: 61 63 74 2c 20 63 6c 6f 73 65 20 74 68 69 73 20 act, close this
1d00: 63 6f 6e 6e 65 63 74 69 6f 6e 20 61 6e 64 20 73 connection and s
1d10: 74 61 72 74 20 61 20 6e 65 77 20 6f 6e 0a 09 20 tart a new on..
1d20: 20 20 20 20 20 28 2b 20 28 68 74 74 70 2d 74 72 (+ (http-tr
1d30: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
1d40: 61 74 2d 67 65 74 2d 6c 61 73 74 2d 61 63 63 65 at-get-last-acce
1d50: 73 73 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 ss (remote-connd
1d60: 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a 09 at runremote))..
1d70: 09 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 . (remote-server
1d80: 2d 74 69 6d 65 6f 75 74 20 72 75 6e 72 65 6d 6f -timeout runremo
1d90: 74 65 29 29 29 29 0a 20 20 20 20 20 20 28 64 65 te)))). (de
1da0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
1db0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1dc0: 72 74 2a 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 20 rt* "Connection
1dd0: 74 6f 20 22 20 28 72 65 6d 6f 74 65 2d 73 65 72 to " (remote-ser
1de0: 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 6d 6f 74 ver-url runremot
1df0: 65 29 20 22 20 65 78 70 69 72 65 64 20 64 75 65 e) " expired due
1e00: 20 74 6f 20 6e 6f 20 61 63 63 65 73 73 65 73 2c to no accesses,
1e10: 20 66 6f 72 63 69 6e 67 20 6e 65 77 20 63 6f 6e forcing new con
1e20: 6e 65 63 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 nection.").
1e30: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1e40: 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f :close-connectio
1e50: 6e 73 20 61 72 65 61 2d 64 61 74 3a 20 72 75 6e ns area-dat: run
1e60: 72 65 6d 6f 74 65 29 0a 20 20 20 20 20 20 28 72 remote). (r
1e70: 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 emote-conndat-se
1e80: 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 66 29 t! runremote #f)
1e90: 20 3b 3b 20 69 6e 76 61 6c 69 64 61 74 65 20 74 ;; invalidate t
1ea0: 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 2c 20 74 he connection, t
1eb0: 68 75 73 20 66 6f 72 63 69 6e 67 20 61 20 6e 65 hus forcing a ne
1ec0: 77 20 63 6f 6e 6e 65 63 74 69 6f 6e 2e 0a 20 20 w connection..
1ed0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
1ee0: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
1ef0: 20 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d (rmt:send-
1f00: 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 receive cmd rid
1f10: 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 params attemptnu
1f20: 6d 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a m: attemptnum)).
1f30: 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 44 4f 54 . ;;DOT
1f40: 20 43 41 53 45 35 20 5b 6c 61 62 65 6c 3d 22 6c CASE5 [label="l
1f50: 6f 63 61 6c 5c 6e 72 65 61 64 22 5d 3b 0a 20 20 ocal\nread"];.
1f60: 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f ;;DOT MUTEXLO
1f70: 43 4b 20 2d 3e 20 43 41 53 45 35 20 5b 6c 61 62 CK -> CASE5 [lab
1f80: 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 el="server not r
1f90: 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d equired,\non hom
1fa0: 65 68 6f 73 74 2c 5c 6e 72 65 61 64 2d 6f 6e 6c ehost,\nread-onl
1fb0: 79 20 71 75 65 72 79 22 5d 3b 20 7b 72 61 6e 6b y query"]; {rank
1fc0: 3d 73 61 6d 65 20 22 63 61 73 65 20 35 22 20 43 =same "case 5" C
1fd0: 41 53 45 35 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f ASE5};. ;;DO
1fe0: 54 20 43 41 53 45 35 20 2d 3e 20 22 72 6d 74 3a T CASE5 -> "rmt:
1ff0: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
2000: 6f 63 61 6c 6c 79 22 3b 0a 0a 20 20 20 20 20 3b ocally";.. ;
2010: 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 61 6e ; on homehost an
2020: 64 20 74 68 69 73 20 69 73 20 61 20 72 65 61 64 d this is a read
2030: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 . ((and (not
2040: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
2050: 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 erver runremote)
2060: 29 20 3b 3b 20 68 6f 6e 6f 72 20 66 6f 72 63 65 ) ;; honor force
2070: 64 20 75 73 65 20 6f 66 20 73 65 72 76 65 72 2c d use of server,
2080: 20 69 2e 65 2e 20 73 65 72 76 65 72 20 4e 4f 54 i.e. server NOT
2090: 20 72 65 71 75 69 72 65 64 0a 09 20 20 20 28 63 required.. (c
20a0: 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 dr (remote-hh-da
20b0: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 t runremote))
20c0: 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f ;; on homeho
20d0: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d st. (m
20e0: 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 ember cmd api:re
20f0: 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 ad-only-queries)
2100: 29 20 20 20 3b 3b 20 74 68 69 73 20 69 73 20 61 ) ;; this is a
2110: 20 72 65 61 64 0a 20 20 20 20 20 20 28 6d 75 74 read. (mut
2120: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d ex-unlock! *rmt-
2130: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 mutex*). (d
2140: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2150: 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 12 *default-log-
2160: 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d port* "rmt:send-
2170: 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 35 receive, case 5
2180: 22 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 "). (rmt:op
2190: 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 en-qry-close-loc
21a0: 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d ally cmd 0 param
21b0: 73 29 29 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 s)).. ;;DOT
21c0: 43 41 53 45 36 20 5b 6c 61 62 65 6c 3d 22 69 6e CASE6 [label="in
21d0: 69 74 5c 6e 72 65 6d 6f 74 65 22 5d 3b 0a 20 20 it\nremote"];.
21e0: 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f ;;DOT MUTEXLO
21f0: 43 4b 20 2d 3e 20 43 41 53 45 36 20 5b 6c 61 62 CK -> CASE6 [lab
2200: 65 6c 3d 22 6f 6e 20 68 6f 6d 65 68 6f 73 74 2c el="on homehost,
2210: 5c 6e 77 72 69 74 65 20 71 75 65 72 79 2c 5c 6e \nwrite query,\n
2220: 68 61 76 65 20 73 65 72 76 65 72 2c 5c 6e 63 61 have server,\nca
2230: 6e 27 74 20 72 65 61 63 68 20 69 74 22 5d 3b 20 n't reach it"];
2240: 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 {rank=same "case
2250: 20 36 22 20 43 41 53 45 36 7d 3b 0a 20 20 20 20 6" CASE6};.
2260: 20 3b 3b 44 4f 54 20 43 41 53 45 36 20 2d 3e 20 ;;DOT CASE6 ->
2270: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
2280: 65 22 3b 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 68 e";. ;; on h
2290: 6f 6d 65 68 6f 73 74 20 61 6e 64 20 74 68 69 73 omehost and this
22a0: 20 69 73 20 61 20 77 72 69 74 65 2c 20 77 65 20 is a write, we
22b0: 61 6c 72 65 61 64 79 20 68 61 76 65 20 61 20 73 already have a s
22c0: 65 72 76 65 72 2c 20 62 75 74 20 73 65 72 76 65 erver, but serve
22d0: 72 20 68 61 73 20 64 69 65 64 0a 20 20 20 20 20 r has died.
22e0: 28 28 61 6e 64 20 28 63 64 72 20 28 72 65 6d 6f ((and (cdr (remo
22f0: 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d te-hh-dat runrem
2300: 6f 74 65 29 29 20 20 20 20 20 20 20 20 20 20 20 ote))
2310: 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 ;; on homehost.
2320: 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 (not (
2330: 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 member cmd api:r
2340: 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 ead-only-queries
2350: 29 29 20 20 3b 3b 20 74 68 69 73 20 69 73 20 61 )) ;; this is a
2360: 20 77 72 69 74 65 0a 20 20 20 20 20 20 20 20 20 write.
2370: 20 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 (remote-server
2380: 2d 75 72 6c 20 72 75 6e 72 65 6d 6f 74 65 29 20 -url runremote)
2390: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 68 ;; h
23a0: 61 76 65 20 61 20 73 65 72 76 65 72 0a 20 20 20 ave a server.
23b0: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 73 65 (not (se
23c0: 72 76 65 72 3a 70 69 6e 67 20 28 72 65 6d 6f 74 rver:ping (remot
23d0: 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e e-server-url run
23e0: 72 65 6d 6f 74 65 29 20 28 72 65 6d 6f 74 65 2d remote) (remote-
23f0: 73 65 72 76 65 72 2d 69 64 20 72 75 6e 72 65 6d server-id runrem
2400: 6f 74 65 29 29 29 29 20 20 3b 3b 20 73 65 72 76 ote)))) ;; serv
2410: 65 72 20 68 61 73 20 64 69 65 64 2e 20 4e 4f 54 er has died. NOT
2420: 45 3a 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 E: this is not a
2430: 20 63 68 65 61 70 20 63 61 6c 6c 21 20 4e 65 65 cheap call! Nee
2440: 64 20 62 65 74 74 65 72 20 61 70 70 72 6f 61 63 d better approac
2450: 68 2e 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a h.. (set! *
2460: 72 75 6e 72 65 6d 6f 74 65 2a 20 28 6d 61 6b 65 runremote* (make
2470: 2d 72 65 6d 6f 74 65 29 29 0a 20 20 20 20 20 20 -remote)).
2480: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 (let* ((server-i
2490: 6e 66 6f 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 nfo (remote-serv
24a0: 65 72 2d 69 6e 66 6f 20 2a 72 75 6e 72 65 6d 6f er-info *runremo
24b0: 74 65 2a 29 29 29 20 0a 20 20 20 20 20 20 20 20 te*))) .
24c0: 20 20 20 20 28 69 66 20 73 65 72 76 65 72 2d 69 (if server-i
24d0: 6e 66 6f 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 nfo...(begin...
24e0: 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
24f0: 75 72 6c 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d url-set! *runrem
2500: 6f 74 65 2a 20 28 73 65 72 76 65 72 3a 72 65 63 ote* (server:rec
2510: 6f 72 64 2d 3e 75 72 6c 20 73 65 72 76 65 72 2d ord->url server-
2520: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
2530: 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 (remote
2540: 2d 73 65 72 76 65 72 2d 69 64 2d 73 65 74 21 20 -server-id-set!
2550: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 73 65 72 *runremote* (ser
2560: 76 65 72 3a 72 65 63 6f 72 64 2d 3e 69 64 20 73 ver:record->id s
2570: 65 72 76 65 72 2d 69 6e 66 6f 29 29 29 29 29 0a erver-info))))).
2580: 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 66 6f (remote-fo
2590: 72 63 65 2d 73 65 72 76 65 72 2d 73 65 74 21 20 rce-server-set!
25a0: 72 75 6e 72 65 6d 6f 74 65 20 28 63 6f 6d 6d 6f runremote (commo
25b0: 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 n:force-server?)
25c0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
25d0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
25e0: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
25f0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
2600: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2610: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
2620: 69 76 65 2c 20 63 61 73 65 20 20 36 22 29 0a 20 ive, case 6").
2630: 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 (rmt:send-r
2640: 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 eceive cmd rid p
2650: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
2660: 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 0a : attemptnum))..
2670: 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 37 ;;DOT CASE7
2680: 20 5b 6c 61 62 65 6c 3d 22 68 6f 6d 65 68 6f 73 [label="homehos
2690: 74 5c 6e 77 72 69 74 65 22 5d 3b 0a 20 20 20 20 t\nwrite"];.
26a0: 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b ;;DOT MUTEXLOCK
26b0: 20 2d 3e 20 43 41 53 45 37 20 5b 6c 61 62 65 6c -> CASE7 [label
26c0: 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 65 71 ="server not req
26d0: 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d 65 68 uired,\non homeh
26e0: 6f 73 74 2c 5c 6e 61 20 77 72 69 74 65 2c 5c 6e ost,\na write,\n
26f0: 68 61 76 65 20 61 20 73 65 72 76 65 72 22 5d 3b have a server"];
2700: 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 {rank=same "cas
2710: 65 20 37 22 20 43 41 53 45 37 7d 3b 0a 20 20 20 e 7" CASE7};.
2720: 20 20 3b 3b 44 4f 54 20 43 41 53 45 37 20 2d 3e ;;DOT CASE7 ->
2730: 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 "rmt:open-qry-c
2740: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 lose-locally";.
2750: 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f ;; on homeho
2760: 73 74 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 st and this is a
2770: 20 77 72 69 74 65 2c 20 77 65 20 61 6c 72 65 61 write, we alrea
2780: 64 79 20 68 61 76 65 20 61 20 73 65 72 76 65 72 dy have a server
2790: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 . ((and (not
27a0: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
27b0: 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 erver runremote)
27c0: 29 20 20 20 20 20 3b 3b 20 68 6f 6e 6f 72 20 66 ) ;; honor f
27d0: 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 65 72 orced use of ser
27e0: 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 65 72 ver, i.e. server
27f0: 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a 09 20 NOT required..
2800: 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 (cdr (remote-h
2810: 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 h-dat runremote)
2820: 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ) ;; o
2830: 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 n homehost.
2840: 20 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 (not (memb
2850: 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d er cmd api:read-
2860: 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 20 20 only-queries))
2870: 3b 3b 20 74 68 69 73 20 69 73 20 61 20 77 72 69 ;; this is a wri
2880: 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 te. (r
2890: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
28a0: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
28b0: 20 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 ;; have
28c0: 61 20 73 65 72 76 65 72 0a 20 20 20 20 20 20 28 a server. (
28d0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 mutex-unlock! *r
28e0: 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 mt-mutex*).
28f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2900: 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 12 *default-l
2910: 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 og-port* "rmt:se
2920: 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 nd-receive, case
2930: 20 20 34 2e 31 22 29 0a 20 20 20 20 20 20 28 72 4.1"). (r
2940: 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 mt:open-qry-clos
2950: 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 e-locally cmd 0
2960: 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 3b params)).. ;
2970: 3b 44 4f 54 20 43 41 53 45 38 20 5b 6c 61 62 65 ;DOT CASE8 [labe
2980: 6c 3d 22 66 6f 72 63 65 5c 6e 73 65 72 76 65 72 l="force\nserver
2990: 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d "];. ;;DOT M
29a0: 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 UTEXLOCK -> CASE
29b0: 38 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 8 [label="server
29c0: 20 6e 6f 74 20 72 65 71 75 69 72 65 64 2c 5c 6e not required,\n
29d0: 68 61 76 65 20 68 6f 6d 65 68 6f 73 74 20 69 6e have homehost in
29e0: 66 6f 2c 5c 6e 6e 6f 20 63 6f 6e 6e 65 63 74 69 fo,\nno connecti
29f0: 6f 6e 20 79 65 74 2c 5c 6e 6e 6f 74 20 61 20 72 on yet,\nnot a r
2a00: 65 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 22 5d ead-only query"]
2a10: 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 ; {rank=same "ca
2a20: 73 65 20 38 22 20 43 41 53 45 38 7d 3b 0a 20 20 se 8" CASE8};.
2a30: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 38 20 2d ;;DOT CASE8 -
2a40: 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d > "rmt:open-qry-
2a50: 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a close-locally";.
2a60: 20 20 20 20 20 3b 3b 20 20 6f 6e 20 68 6f 6d 65 ;; on home
2a70: 68 6f 73 74 2c 20 6e 6f 20 73 65 72 76 65 72 20 host, no server
2a80: 63 6f 6e 74 61 63 74 20 6d 61 64 65 20 61 6e 64 contact made and
2a90: 20 74 68 69 73 20 69 73 20 61 20 77 72 69 74 65 this is a write
2aa0: 2c 20 70 61 73 73 69 76 65 6c 79 20 73 74 61 72 , passively star
2ab0: 74 20 61 20 73 65 72 76 65 72 20 0a 20 20 20 20 t a server .
2ac0: 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 72 65 6d ((and (not (rem
2ad0: 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 ote-force-server
2ae0: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
2af0: 20 3b 3b 20 68 6f 6e 6f 72 20 66 6f 72 63 65 64 ;; honor forced
2b00: 20 75 73 65 20 6f 66 20 73 65 72 76 65 72 2c 20 use of server,
2b10: 69 2e 65 2e 20 73 65 72 76 65 72 20 4e 4f 54 20 i.e. server NOT
2b20: 72 65 71 75 69 72 65 64 0a 09 20 20 20 28 63 64 required.. (cd
2b30: 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 r (remote-hh-dat
2b40: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
2b50: 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 68 ;; have h
2b60: 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 20 omehost.
2b70: 20 20 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d (not (remote-
2b80: 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 server-url runre
2b90: 6d 6f 74 65 29 29 20 20 20 20 20 20 20 3b 3b 20 mote)) ;;
2ba0: 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 79 65 no connection ye
2bb0: 74 0a 09 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 t.. (not (memb
2bc0: 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d er cmd api:read-
2bd0: 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 29 20 only-queries)))
2be0: 3b 3b 20 6e 6f 74 20 61 20 72 65 61 64 2d 6f 6e ;; not a read-on
2bf0: 6c 79 20 71 75 65 72 79 0a 20 20 20 20 20 20 28 ly query. (
2c00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2c10: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
2c20: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
2c30: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
2c40: 38 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 8"). (let (
2c50: 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 20 28 73 (server-info (s
2c60: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
2c70: 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a unning *toppath*
2c80: 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 3a 72 ))) ;; (server:r
2c90: 65 61 64 2d 64 6f 74 73 65 72 76 65 72 2d 3e 75 ead-dotserver->u
2ca0: 72 6c 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 20 rl *toppath*)))
2cb0: 3b 3b 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b ;; (server:check
2cc0: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 -if-running *top
2cd0: 70 61 74 68 2a 29 29 29 20 3b 3b 20 44 6f 20 4e path*))) ;; Do N
2ce0: 4f 54 20 77 61 6e 74 20 74 6f 20 72 75 6e 20 73 OT want to run s
2cf0: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
2d00: 75 6e 6e 69 6e 67 20 2d 20 76 65 72 79 20 65 78 unning - very ex
2d10: 70 65 6e 73 69 76 65 20 74 6f 20 64 6f 20 66 6f pensive to do fo
2d20: 72 20 65 76 65 72 79 20 77 72 69 74 65 20 63 61 r every write ca
2d30: 6c 6c 0a 09 28 69 66 20 73 65 72 76 65 72 2d 69 ll..(if server-i
2d40: 6e 66 6f 0a 09 20 20 20 20 28 62 65 67 69 6e 0a nfo.. (begin.
2d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
2d60: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
2d70: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
2d80: 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e (server:record->
2d90: 75 72 6c 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 url server-info)
2da0: 29 20 3b 3b 20 74 68 65 20 73 74 72 69 6e 67 20 ) ;; the string
2db0: 63 61 6e 20 62 65 20 63 6f 6e 73 75 6d 65 64 20 can be consumed
2dc0: 62 79 20 74 68 65 20 63 6c 69 65 6e 74 20 73 65 by the client se
2dd0: 74 75 70 20 69 66 20 6e 65 65 64 65 64 0a 20 20 tup if needed.
2de0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 6d (rem
2df0: 6f 74 65 2d 73 65 72 76 65 72 2d 69 64 2d 73 65 ote-server-id-se
2e00: 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 73 65 t! runremote (se
2e10: 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 69 64 20 rver:record->id
2e20: 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 29 20 20 server-info)))
2e30: 0a 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
2e40: 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 n:force-server?)
2e50: 0a 09 09 28 73 65 72 76 65 72 3a 73 74 61 72 74 ...(server:start
2e60: 2d 61 6e 64 2d 77 61 69 74 20 2a 74 6f 70 70 61 -and-wait *toppa
2e70: 74 68 2a 29 0a 09 09 28 73 65 72 76 65 72 3a 6b th*)...(server:k
2e80: 69 6e 64 2d 72 75 6e 20 2a 74 6f 70 70 61 74 68 ind-run *toppath
2e90: 2a 29 29 29 0a 20 20 20 20 20 20 28 72 65 6d 6f *))). (remo
2ea0: 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 2d te-force-server-
2eb0: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 set! runremote (
2ec0: 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 common:force-ser
2ed0: 76 65 72 3f 29 29 0a 20 20 20 20 20 20 28 6d 75 ver?)). (mu
2ee0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
2ef0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
2f00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2f10: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
2f20: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
2f30: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
2f40: 38 2e 31 22 29 0a 20 20 20 20 20 20 28 72 6d 74 8.1"). (rmt
2f50: 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d :open-qry-close-
2f60: 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 locally cmd 0 pa
2f70: 72 61 6d 73 29 29 29 0a 0a 20 20 20 20 20 3b 3b rams))).. ;;
2f80: 44 4f 54 20 43 41 53 45 39 20 5b 6c 61 62 65 6c DOT CASE9 [label
2f90: 3d 22 66 6f 72 63 65 20 73 65 72 76 65 72 5c 6e ="force server\n
2fa0: 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 not on homehost"
2fb0: 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 ];. ;;DOT MU
2fc0: 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 39 TEXLOCK -> CASE9
2fd0: 20 5b 6c 61 62 65 6c 3d 22 6e 6f 20 63 6f 6e 6e [label="no conn
2fe0: 65 63 74 69 6f 6e 5c 6e 61 6e 64 20 65 69 74 68 ection\nand eith
2ff0: 65 72 20 72 65 71 75 69 72 65 20 73 65 72 76 65 er require serve
3000: 72 5c 6e 6f 72 20 6e 6f 74 20 6f 6e 20 68 6f 6d r\nor not on hom
3010: 65 68 6f 73 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 ehost"]; {rank=s
3020: 61 6d 65 20 22 63 61 73 65 20 39 22 20 43 41 53 ame "case 9" CAS
3030: 45 39 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 E9};. ;;DOT
3040: 43 41 53 45 39 20 2d 3e 20 22 73 74 61 72 74 5c CASE9 -> "start\
3050: 6e 73 65 72 76 65 72 22 20 2d 3e 20 22 72 6d 74 nserver" -> "rmt
3060: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 22 3b 0a :send-receive";.
3070: 20 20 20 20 20 28 28 6f 72 20 28 61 6e 64 20 28 ((or (and (
3080: 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 remote-force-ser
3090: 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 20 20 ver runremote)
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 77 ;; w
30b0: 65 20 61 72 65 20 66 6f 72 63 69 6e 67 20 61 20 e are forcing a
30c0: 73 65 72 76 65 72 20 61 6e 64 20 64 6f 6e 27 74 server and don't
30d0: 20 79 65 74 20 68 61 76 65 20 61 20 63 6f 6e 6e yet have a conn
30e0: 65 63 74 69 6f 6e 20 74 6f 20 6f 6e 65 0a 09 20 ection to one..
30f0: 20 20 20 20 20 20 28 6e 6f 74 20 28 72 65 6d 6f (not (remo
3100: 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 te-conndat runre
3110: 6d 6f 74 65 29 29 29 0a 09 20 20 28 61 6e 64 20 mote))).. (and
3120: 28 6e 6f 74 20 28 63 64 72 20 28 72 65 6d 6f 74 (not (cdr (remot
3130: 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f e-hh-dat runremo
3140: 74 65 29 29 29 20 20 20 20 20 20 20 20 3b 3b 20 te))) ;;
3150: 6e 6f 74 20 6f 6e 20 61 20 68 6f 6d 65 68 6f 73 not on a homehos
3160: 74 20 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 t .. (not
3170: 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 (remote-conndat
3180: 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 20 20 runremote))))
3190: 20 20 20 20 20 20 20 20 3b 3b 20 61 6e 64 20 6e ;; and n
31a0: 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 20 20 o connection.
31b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
31c0: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
31d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
31e0: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
31f0: 73 65 20 39 2c 20 68 68 2d 64 61 74 3a 20 22 20 se 9, hh-dat: "
3200: 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 (remote-hh-dat r
3210: 75 6e 72 65 6d 6f 74 65 29 20 22 20 63 6f 6e 6e unremote) " conn
3220: 64 61 74 3a 20 22 20 28 72 65 6d 6f 74 65 2d 63 dat: " (remote-c
3230: 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 onndat runremote
3240: 29 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d )). (mutex-
3250: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
3260: 65 78 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 ex*). (if (
3270: 6e 6f 74 20 28 73 65 72 76 65 72 3a 63 68 65 63 not (server:chec
3280: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
3290: 70 70 61 74 68 2a 29 29 20 3b 3b 20 77 68 6f 20 ppath*)) ;; who
32a0: 6b 6e 6f 77 73 2c 20 6d 61 79 62 65 20 6f 6e 65 knows, maybe one
32b0: 20 68 61 73 20 73 74 61 72 74 65 64 20 75 70 3f has started up?
32c0: 0a 09 20 20 28 73 65 72 76 65 72 3a 73 74 61 72 .. (server:star
32d0: 74 2d 61 6e 64 2d 77 61 69 74 20 2a 74 6f 70 70 t-and-wait *topp
32e0: 61 74 68 2a 29 29 0a 20 20 20 20 20 20 28 72 65 ath*)). (re
32f0: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 mote-conndat-set
3300: 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 72 6d 74 ! runremote (rmt
3310: 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d :get-connection-
3320: 69 6e 66 6f 20 2a 74 6f 70 70 61 74 68 2a 29 29 info *toppath*))
3330: 20 3b 3b 20 63 61 6c 6c 73 20 63 6c 69 65 6e 74 ;; calls client
3340: 3a 73 65 74 75 70 20 77 68 69 63 68 20 63 61 6c :setup which cal
3350: 6c 73 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 2d ls client:setup-
3360: 68 74 74 70 0a 20 20 20 20 20 20 28 72 6d 74 3a http. (rmt:
3370: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
3380: 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 rid params atte
3390: 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e mptnum: attemptn
33a0: 75 6d 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 61 64 um)) ;; TODO: ad
33b0: 64 20 62 61 63 6b 2d 6f 66 66 20 74 69 6d 65 6f d back-off timeo
33c0: 75 74 20 61 73 0a 0a 20 20 20 20 20 3b 3b 44 4f ut as.. ;;DO
33d0: 54 20 43 41 53 45 31 30 20 5b 6c 61 62 65 6c 3d T CASE10 [label=
33e0: 22 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b 0a "on homehost"];.
33f0: 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 ;;DOT MUTEX
3400: 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 31 30 20 5b LOCK -> CASE10 [
3410: 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f label="server no
3420: 74 20 72 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 t required,\non
3430: 68 6f 6d 65 68 6f 73 74 22 5d 3b 20 7b 72 61 6e homehost"]; {ran
3440: 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 31 30 22 k=same "case 10"
3450: 20 43 41 53 45 31 30 7d 3b 0a 20 20 20 20 20 3b CASE10};. ;
3460: 3b 44 4f 54 20 43 41 53 45 31 30 20 2d 3e 20 22 ;DOT CASE10 -> "
3470: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
3480: 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 20 20 se-locally";.
3490: 20 20 3b 3b 20 61 6c 6c 20 73 65 74 20 75 70 20 ;; all set up
34a0: 69 66 20 67 65 74 20 74 68 69 73 20 66 61 72 2c if get this far,
34b0: 20 64 69 73 70 61 74 63 68 20 74 68 65 20 71 75 dispatch the qu
34c0: 65 72 79 0a 20 20 20 20 20 28 28 61 6e 64 20 28 ery. ((and (
34d0: 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 not (remote-forc
34e0: 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f e-server runremo
34f0: 74 65 29 29 0a 09 20 20 20 28 63 64 72 20 28 72 te)).. (cdr (r
3500: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e emote-hh-dat run
3510: 72 65 6d 6f 74 65 29 29 29 20 3b 3b 20 77 65 20 remote))) ;; we
3520: 61 72 65 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a are on homehost.
3530: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
3540: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
3550: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
3560: 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 rint-info 12 *de
3570: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3580: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
3590: 65 2c 20 63 61 73 65 20 31 30 22 29 0a 20 20 20 e, case 10").
35a0: 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (rmt:open-qry
35b0: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
35c0: 6d 64 20 28 69 66 20 72 69 64 20 72 69 64 20 30 md (if rid rid 0
35d0: 29 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 ) params))..
35e0: 20 3b 3b 44 4f 54 20 43 41 53 45 31 31 20 5b 6c ;;DOT CASE11 [l
35f0: 61 62 65 6c 3d 22 73 65 6e 64 5f 72 65 63 65 69 abel="send_recei
3600: 76 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 ve"];. ;;DOT
3610: 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 MUTEXLOCK -> CA
3620: 53 45 31 31 20 5b 6c 61 62 65 6c 3d 22 65 6c 73 SE11 [label="els
3630: 65 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 e"]; {rank=same
3640: 22 63 61 73 65 20 31 31 22 20 43 41 53 45 31 31 "case 11" CASE11
3650: 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 };. ;;DOT CA
3660: 53 45 31 31 20 2d 3e 20 22 72 6d 74 3a 73 65 6e SE11 -> "rmt:sen
3670: 64 2d 72 65 63 65 69 76 65 22 20 5b 6c 61 62 65 d-receive" [labe
3680: 6c 3d 22 63 61 6c 6c 20 66 61 69 6c 65 64 22 5d l="call failed"]
3690: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 ;. ;;DOT CAS
36a0: 45 31 31 20 2d 3e 20 22 52 45 53 55 4c 54 22 20 E11 -> "RESULT"
36b0: 5b 6c 61 62 65 6c 3d 22 63 61 6c 6c 20 73 75 63 [label="call suc
36c0: 63 65 65 64 65 64 22 5d 3b 0a 20 20 20 20 20 3b ceeded"];. ;
36d0: 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 ; not on homehos
36e0: 74 2c 20 64 6f 20 73 65 72 76 65 72 20 71 75 65 t, do server que
36f0: 72 79 0a 20 20 20 20 20 28 65 6c 73 65 20 28 65 ry. (else (e
3700: 78 74 72 61 73 2d 63 61 73 65 2d 31 31 20 2a 64 xtras-case-11 *d
3710: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3720: 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 70 runremote cmd p
3730: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
3740: 20 72 69 64 29 29 29 29 29 0a 20 20 20 20 3b 3b rid))))). ;;
3750: 44 4f 54 20 7d 0a 0a 3b 3b 20 62 75 6e 63 68 20 DOT }..;; bunch
3760: 6f 66 20 73 6d 61 6c 6c 20 66 75 6e 63 74 69 6f of small functio
3770: 6e 73 20 66 61 63 74 6f 72 65 64 20 6f 75 74 20 ns factored out
3780: 6f 66 20 73 65 6e 64 2d 72 65 63 65 69 76 65 20 of send-receive
3790: 74 6f 20 6d 61 6b 65 20 64 65 62 75 67 20 65 61 to make debug ea
37a0: 73 69 65 72 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 sier.;;..(define
37b0: 20 28 65 78 74 72 61 73 2d 63 61 73 65 2d 31 31 (extras-case-11
37c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
37d0: 72 74 2a 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d rt* runremote cm
37e0: 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 d params attempt
37f0: 6e 75 6d 20 72 69 64 29 0a 20 20 3b 3b 20 28 6d num rid). ;; (m
3800: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d utex-unlock! *rm
3810: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 64 65 62 t-mutex*). (deb
3820: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 ug:print-info 12
3830: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3840: 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 rt* "rmt:send-re
3850: 63 65 69 76 65 2c 20 63 61 73 65 20 20 39 22 29 ceive, case 9")
3860: 0a 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 . ;; (mutex-loc
3870: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
3880: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 69 6e (let* ((connin
3890: 66 6f 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 fo (remote-connd
38a0: 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a 09 at runremote))..
38b0: 20 28 64 61 74 2d 69 6e 20 20 20 20 20 20 28 63 (dat-in (c
38c0: 61 73 65 20 28 72 65 6d 6f 74 65 2d 74 72 61 6e ase (remote-tran
38d0: 73 70 6f 72 74 20 72 75 6e 72 65 6d 6f 74 65 29 sport runremote)
38e0: 0a 09 09 20 20 20 20 20 28 28 68 74 74 70 29 20 ... ((http)
38f0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 (condition-case
3900: 3b 3b 20 68 61 6e 64 6c 69 6e 67 20 68 65 72 65 ;; handling here
3910: 20 68 61 73 0a 09 09 09 09 09 20 20 20 20 20 3b has...... ;
3920: 3b 20 63 61 75 73 65 64 20 61 20 6c 6f 74 20 6f ; caused a lot o
3930: 66 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 20 70 f...... ;; p
3940: 72 6f 62 6c 65 6d 73 2e 20 48 6f 77 65 76 65 72 roblems. However
3950: 20 69 74 0a 09 09 09 09 09 20 20 20 20 20 3b 3b it...... ;;
3960: 20 69 73 20 6e 65 65 64 65 64 20 74 6f 20 64 65 is needed to de
3970: 61 6c 20 77 69 74 68 0a 09 09 09 09 09 20 20 20 al with......
3980: 20 20 3b 3b 20 61 74 74 65 6d 74 70 65 64 0a 09 ;; attemtped..
3990: 09 09 09 09 20 20 20 20 20 3b 3b 20 63 6f 6d 6d .... ;; comm
39a0: 75 6e 69 63 61 74 69 6f 6e 20 74 6f 0a 09 09 09 unication to....
39b0: 09 09 20 20 20 20 20 3b 3b 20 73 65 72 76 65 72 .. ;; server
39c0: 73 20 74 68 61 74 20 68 61 76 65 20 67 6f 6e 65 s that have gone
39d0: 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 20 61 77 ...... ;; aw
39e0: 61 79 0a 09 09 09 20 20 20 20 20 20 28 68 74 74 ay.... (htt
39f0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
3a00: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
3a10: 69 76 65 20 30 20 63 6f 6e 6e 69 6e 66 6f 20 63 ive 0 conninfo c
3a20: 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 20 20 20 md params).
3a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a40: 20 20 20 20 20 20 20 20 20 28 28 73 65 72 76 65 ((serve
3a50: 72 6d 69 73 6d 61 74 63 68 29 20 20 28 76 65 63 rmismatch) (vec
3a60: 74 6f 72 20 23 66 20 22 53 65 72 76 65 72 20 69 tor #f "Server i
3a70: 64 20 6d 69 73 6d 61 74 63 68 22 20 29 29 0a 09 d mismatch" ))..
3a80: 09 09 20 20 20 20 20 20 28 28 63 6f 6d 6d 66 61 .. ((commfa
3a90: 69 6c 29 28 76 65 63 74 6f 72 20 23 66 20 22 63 il)(vector #f "c
3aa0: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 20 66 61 ommunications fa
3ab0: 69 6c 22 29 29 0a 09 09 09 20 20 20 20 20 20 28 il")).... (
3ac0: 28 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 20 (exn)(vector #f
3ad0: 22 6f 74 68 65 72 20 66 61 69 6c 22 20 28 70 72 "other fail" (pr
3ae0: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 int-call-chain))
3af0: 29 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 )))... (else
3b00: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
3b10: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
3b20: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
3b30: 52 3a 20 74 72 61 6e 73 70 6f 72 74 20 22 20 28 R: transport " (
3b40: 72 65 6d 6f 74 65 2d 74 72 61 6e 73 70 6f 72 74 remote-transport
3b50: 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 20 6e 6f runremote) " no
3b60: 74 20 73 75 70 70 6f 72 74 65 64 22 29 0a 09 09 t supported")...
3b70: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 29 0a (exit)))).
3b80: 0a 3b 3b 20 4e 6f 20 54 69 74 6c 65 20 0a 3b 3b .;; No Title .;;
3b90: 20 45 72 72 6f 72 3a 20 28 76 65 63 74 6f 72 2d Error: (vector-
3ba0: 72 65 66 29 20 6f 75 74 20 6f 66 20 72 61 6e 67 ref) out of rang
3bb0: 65 0a 3b 3b 20 23 28 23 3c 63 6f 6e 64 69 74 69 e.;; #(#<conditi
3bc0: 6f 6e 3a 20 28 65 78 6e 20 74 79 70 65 29 3e 20 on: (exn type)>
3bd0: 28 23 28 22 64 62 2e 73 63 6d 3a 33 37 34 30 3a (#("db.scm:3740:
3be0: 20 72 65 67 65 78 23 72 65 67 65 78 70 22 20 23 regex#regexp" #
3bf0: 66 20 23 66 29 20 23 28 22 64 62 2e 73 63 6d 3a f #f) #("db.scm:
3c00: 33 37 33 39 3a 20 72 65 67 65 78 23 73 74 72 69 3739: regex#stri
3c10: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 22 20 23 ng-substitute" #
3c20: 66 20 23 66 29 20 23 28 22 64 62 2e 73 63 6d 3a f #f) #("db.scm:
3c30: 33 37 33 38 3a 20 62 61 73 65 36 34 23 62 61 73 3738: base64#bas
3c40: 65 36 34 2d 64 65 63 6f 64 65 22 20 23 66 20 23 e64-decode" #f #
3c50: 66 29 20 23 28 22 64 62 2e 73 63 6d 3a 33 37 33 f) #("db.scm:373
3c60: 37 3a 20 7a 33 23 7a 33 3a 64 65 63 6f 64 65 2d 7: z3#z3:decode-
3c70: 62 75 66 66 65 72 22 20 23 66 20 23 66 29 20 23 buffer" #f #f) #
3c80: 28 22 64 62 2e 73 63 6d 3a 33 37 33 36 3a 20 77 ("db.scm:3736: w
3c90: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 ith-input-from-s
3ca0: 74 72 69 6e 67 22 20 23 66 20 23 66 29 20 23 28 tring" #f #f) #(
3cb0: 22 64 62 2e 73 63 6d 3a 33 37 34 31 3a 20 73 31 "db.scm:3741: s1
3cc0: 31 6e 23 64 65 73 65 72 69 61 6c 69 7a 65 22 20 1n#deserialize"
3cd0: 23 66 20 23 66 29 20 23 28 22 61 70 69 2e 73 63 #f #f) #("api.sc
3ce0: 6d 3a 33 37 34 3a 20 61 70 69 3a 65 78 65 63 75 m:374: api:execu
3cf0: 74 65 2d 72 65 71 75 65 73 74 73 22 20 23 66 20 te-requests" #f
3d00: 23 66 29 20 23 28 22 61 70 69 2e 73 63 6d 3a 31 #f) #("api.scm:1
3d10: 33 39 3a 20 63 61 6c 6c 2d 77 69 74 68 2d 63 75 39: call-with-cu
3d20: 72 72 65 6e 74 2d 63 6f 6e 74 69 6e 75 61 74 69 rrent-continuati
3d30: 6f 6e 22 20 23 66 20 23 66 29 20 23 28 22 61 70 on" #f #f) #("ap
3d40: 69 2e 73 63 6d 3a 31 33 39 3a 20 77 69 74 68 2d i.scm:139: with-
3d50: 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e 64 6c 65 exception-handle
3d60: 72 22 20 23 66 20 23 66 29 20 23 28 22 61 70 69 r" #f #f) #("api
3d70: 2e 73 63 6d 3a 31 33 39 3a 20 23 23 73 79 73 23 .scm:139: ##sys#
3d80: 63 61 6c 6c 2d 77 69 74 68 2d 76 61 6c 75 65 73 call-with-values
3d90: 22 20 23 66 20 23 66 29 20 23 28 22 61 70 69 2e " #f #f) #("api.
3da0: 73 63 6d 3a 31 35 38 3a 20 73 74 72 69 6e 67 2d scm:158: string-
3db0: 3e 73 79 6d 62 6f 6c 22 20 23 66 20 23 66 29 20 >symbol" #f #f)
3dc0: 23 28 22 61 70 69 2e 73 63 6d 3a 31 36 30 3a 20 #("api.scm:160:
3dd0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
3de0: 6f 6e 64 73 22 20 23 66 20 23 66 29 20 23 28 22 onds" #f #f) #("
3df0: 61 70 69 2e 73 63 6d 3a 31 36 31 3a 20 64 62 72 api.scm:161: dbr
3e00: 3a 64 62 73 74 72 75 63 74 2d 72 65 61 64 2d 6f :dbstruct-read-o
3e10: 6e 6c 79 22 20 23 66 20 23 66 29 20 23 28 22 61 nly" #f #f) #("a
3e20: 70 69 2e 73 63 6d 3a 31 33 39 3a 20 6b 31 35 22 pi.scm:139: k15"
3e30: 20 23 66 20 23 66 29 20 23 28 22 61 70 69 2e 73 #f #f) #("api.s
3e40: 63 6d 3a 31 33 39 3a 20 67 31 39 22 20 23 66 20 cm:139: g19" #f
3e50: 23 66 29 20 23 28 22 61 70 69 2e 73 63 6d 3a 31 #f) #("api.scm:1
3e60: 34 32 3a 20 67 65 74 2d 63 61 6c 6c 2d 63 68 61 42: get-call-cha
3e70: 69 6e 22 20 23 66 20 23 66 29 29 20 23 28 22 67 in" #f #f)) #("g
3e80: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
3e90: 69 64 22 20 28 31 31 30 32 20 35 30 37 32 39 39 id" (1102 507299
3ea0: 29 29 29 0a 3b 3b 20 36 0a 3b 3b 20 0a 3b 3b 20 ))).;; 6.;; .;;
3eb0: 09 43 61 6c 6c 20 68 69 73 74 6f 72 79 3a 0a 3b .Call history:.;
3ec0: 3b 20 0a 3b 3b 20 09 68 74 74 70 2d 74 72 61 6e ; .;; .http-tran
3ed0: 73 70 6f 72 74 2e 73 63 6d 3a 33 30 36 3a 20 74 sport.scm:306: t
3ee0: 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 hread-terminate!
3ef0: 09 20 20 0a 3b 3b 20 09 68 74 74 70 2d 74 72 61 . .;; .http-tra
3f00: 6e 73 70 6f 72 74 2e 73 63 6d 3a 33 30 37 3a 20 nsport.scm:307:
3f10: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3f20: 09 20 20 0a 3b 3b 20 09 63 6f 6d 6d 6f 6e 5f 72 . .;; .common_r
3f30: 65 63 6f 72 64 73 2e 73 63 6d 3a 32 33 35 3a 20 ecords.scm:235:
3f40: 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 debug:debug-mode
3f50: 09 20 20 0a 3b 3b 20 09 72 6d 74 2e 73 63 6d 3a . .;; .rmt.scm:
3f60: 32 35 39 3a 20 6b 35 38 37 09 20 20 0a 3b 3b 20 259: k587. .;;
3f70: 09 72 6d 74 2e 73 63 6d 3a 32 35 39 3a 20 67 35 .rmt.scm:259: g5
3f80: 39 31 09 20 20 0a 3b 3b 20 09 72 6d 74 2e 73 63 91. .;; .rmt.sc
3f90: 6d 3a 32 37 36 3a 20 68 74 74 70 2d 74 72 61 6e m:276: http-tran
3fa0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
3fb0: 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 -update-last-acc
3fc0: 65 73 73 09 20 20 0a 3b 3b 20 09 68 74 74 70 2d ess. .;; .http-
3fd0: 74 72 61 6e 73 70 6f 72 74 2e 73 63 6d 3a 33 36 transport.scm:36
3fe0: 34 3a 20 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 4: current-secon
3ff0: 64 73 09 20 20 0a 3b 3b 20 09 72 6d 74 2e 73 63 ds. .;; .rmt.sc
4000: 6d 3a 32 38 32 3a 20 64 65 62 75 67 3a 70 72 69 m:282: debug:pri
4010: 6e 74 2d 69 6e 66 6f 09 20 20 0a 3b 3b 20 09 63 nt-info. .;; .c
4020: 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 ommon_records.sc
4030: 6d 3a 32 33 35 3a 20 64 65 62 75 67 3a 64 65 62 m:235: debug:deb
4040: 75 67 2d 6d 6f 64 65 09 20 20 0a 3b 3b 20 09 72 ug-mode. .;; .r
4050: 6d 74 2e 73 63 6d 3a 32 38 33 3a 20 6d 75 74 65 mt.scm:283: mute
4060: 78 2d 75 6e 6c 6f 63 6b 21 09 20 20 0a 3b 3b 20 x-unlock!. .;;
4070: 09 72 6d 74 2e 73 63 6d 3a 32 38 37 3a 20 65 78 .rmt.scm:287: ex
4080: 74 72 61 73 2d 74 72 61 6e 73 70 6f 72 74 2d 73 tras-transport-s
4090: 75 63 63 65 64 65 64 09 20 20 09 3c 2d 2d 0a 3b ucceded. .<--.;
40a0: 3b 20 2b 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ; +-------------
40b0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
40c0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
40d0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
40e0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
40f0: 2b 0a 3b 3b 20 7c 20 45 78 69 74 20 53 74 61 74 +.;; | Exit Stat
4100: 75 73 20 20 20 20 3a 20 37 30 20 20 0a 3b 3b 20 us : 70 .;;
4110: 20 0a 0a 09 20 28 64 61 74 20 20 20 20 20 20 28 ... (dat (
4120: 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f if (and (vector?
4130: 20 64 61 74 2d 69 6e 29 20 3b 3b 20 2e 2e 2e 20 dat-in) ;; ...
4140: 63 68 65 63 6b 20 69 74 20 69 73 20 61 20 63 6f check it is a co
4150: 72 72 65 63 74 20 73 69 7a 65 0a 09 09 09 20 20 rrect size....
4160: 20 20 28 3e 20 28 76 65 63 74 6f 72 2d 6c 65 6e (> (vector-len
4170: 67 74 68 20 64 61 74 2d 69 6e 29 20 31 29 29 0a gth dat-in) 1)).
4180: 09 09 20 20 20 20 20 20 20 64 61 74 2d 69 6e 0a .. dat-in.
4190: 09 09 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 .. (vector
41a0: 20 23 66 20 28 63 6f 6e 63 20 22 63 6f 6d 6d 75 #f (conc "commu
41b0: 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 6c 20 28 nications fail (
41c0: 74 79 70 65 20 32 29 2c 20 64 61 74 2d 69 6e 3d type 2), dat-in=
41d0: 22 20 64 61 74 2d 69 6e 29 29 29 29 0a 09 20 28 " dat-in)))).. (
41e0: 73 75 63 63 65 73 73 20 20 28 69 66 20 28 76 65 success (if (ve
41f0: 63 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 74 ctor? dat) (vect
4200: 6f 72 2d 72 65 66 20 64 61 74 20 30 29 20 23 66 or-ref dat 0) #f
4210: 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 28 )).. (res (
4220: 69 66 20 28 76 65 63 74 6f 72 3f 20 64 61 74 29 if (vector? dat)
4230: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 (vector-ref dat
4240: 20 31 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 1) #f))). (i
4250: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
4260: 63 6f 6e 6e 69 6e 66 6f 29 20 28 3c 20 35 20 28 conninfo) (< 5 (
4270: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 63 6f vector-length co
4280: 6e 6e 69 6e 66 6f 29 29 29 0a 09 28 68 74 74 70 nninfo)))..(http
4290: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
42a0: 72 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 r-dat-update-las
42b0: 74 2d 61 63 63 65 73 73 20 63 6f 6e 6e 69 6e 66 t-access conninf
42c0: 6f 29 20 3b 3b 20 72 65 66 72 65 73 68 20 61 63 o) ;; refresh ac
42d0: 63 65 73 73 20 74 69 6d 65 0a 09 28 62 65 67 69 cess time..(begi
42e0: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
42f0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
4300: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 68 -port* "INFO: Sh
4310: 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 68 65 72 ould not get her
4320: 65 21 20 63 6f 6e 6e 69 6e 66 6f 3d 22 20 63 6f e! conninfo=" co
4330: 6e 6e 69 6e 66 6f 29 0a 09 20 20 28 73 65 74 21 nninfo).. (set!
4340: 20 63 6f 6e 6e 69 6e 66 6f 20 23 66 29 0a 09 20 conninfo #f)..
4350: 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 (remote-conndat
4360: 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 -set! *runremote
4370: 2a 20 23 66 29 20 3b 3b 20 4e 4f 54 45 3a 20 2a * #f) ;; NOTE: *
4380: 72 75 6e 72 65 6d 6f 74 65 2a 20 69 73 20 67 6c runremote* is gl
4390: 6f 62 61 6c 20 63 6f 70 79 20 6f 66 20 72 75 6e obal copy of run
43a0: 72 65 6d 6f 74 65 2e 20 50 75 72 70 6f 73 65 3a remote. Purpose:
43b0: 20 66 61 63 74 6f 72 20 6f 75 74 20 67 6c 6f 62 factor out glob
43c0: 61 6c 2e 0a 09 20 20 28 68 74 74 70 2d 74 72 61 al... (http-tra
43d0: 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e nsport:close-con
43e0: 6e 65 63 74 69 6f 6e 73 20 20 61 72 65 61 2d 64 nections area-d
43f0: 61 74 3a 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 at: runremote)))
4400: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4410: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
4420: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
4430: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
4440: 63 61 73 65 20 20 39 2e 20 63 6f 6e 6e 69 6e 66 case 9. conninf
4450: 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f 20 22 20 64 o=" conninfo " d
4460: 61 74 3d 22 20 64 61 74 20 22 20 72 75 6e 72 65 at=" dat " runre
4470: 6d 6f 74 65 20 3d 20 22 20 72 75 6e 72 65 6d 6f mote = " runremo
4480: 74 65 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 te). (mutex-u
4490: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
44a0: 78 2a 29 0a 20 20 20 20 28 69 66 20 73 75 63 63 x*). (if succ
44b0: 65 73 73 20 3b 3b 20 73 75 63 63 65 73 73 20 6f ess ;; success o
44c0: 6e 6c 79 20 74 65 6c 6c 73 20 75 73 20 74 68 61 nly tells us tha
44d0: 74 20 74 68 65 20 74 72 61 6e 73 70 6f 72 74 20 t the transport
44e0: 77 61 73 0a 09 3b 3b 20 73 75 63 63 65 73 73 66 was..;; successf
44f0: 75 6c 2c 20 68 61 76 65 20 74 6f 20 65 78 61 6d ul, have to exam
4500: 69 6e 65 20 74 68 65 20 64 61 74 61 20 74 6f 20 ine the data to
4510: 73 65 65 20 69 66 0a 09 3b 3b 20 74 68 65 72 65 see if..;; there
4520: 20 77 61 73 20 61 20 64 65 74 65 63 74 65 64 20 was a detected
4530: 69 73 73 75 65 20 61 74 20 74 68 65 20 6f 74 68 issue at the oth
4540: 65 72 20 65 6e 64 0a 09 28 65 78 74 72 61 73 2d er end..(extras-
4550: 74 72 61 6e 73 70 6f 72 74 2d 73 75 63 63 65 64 transport-succed
4560: 65 64 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d ed *default-log-
4570: 70 6f 72 74 2a 20 2a 72 6d 74 2d 6d 75 74 65 78 port* *rmt-mutex
4580: 2a 20 61 74 74 65 6d 70 74 6e 75 6d 20 72 75 6e * attemptnum run
4590: 72 65 6d 6f 74 65 20 72 65 73 20 70 61 72 61 6d remote res param
45a0: 73 20 72 69 64 20 63 6d 64 29 0a 09 28 62 65 67 s rid cmd)..(beg
45b0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 in. (d
45c0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
45d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
45e0: 70 6f 72 74 2a 20 22 20 64 61 74 3d 22 20 64 61 port* " dat=" da
45f0: 74 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 t) . (
4600: 65 78 74 72 61 73 2d 74 72 61 6e 73 70 6f 72 74 extras-transport
4610: 2d 66 61 69 6c 65 64 20 2a 64 65 66 61 75 6c 74 -failed *default
4620: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 2a 72 6d 74 2d -log-port* *rmt-
4630: 6d 75 74 65 78 2a 20 61 74 74 65 6d 70 74 6e 75 mutex* attemptnu
4640: 6d 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 m runremote cmd
4650: 72 69 64 20 70 61 72 61 6d 73 29 29 0a 09 29 29 rid params))..))
4660: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
4670: 70 72 69 6e 74 2d 64 62 2d 73 74 61 74 73 29 0a print-db-stats).
4680: 20 20 28 6c 65 74 20 28 28 66 6d 74 73 74 72 20 (let ((fmtstr
4690: 22 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 7e 32 30 "~40a~7-d~9-d~20
46a0: 2c 32 2d 66 22 29 29 20 3b 3b 20 22 7e 32 30 2c ,2-f")) ;; "~20,
46b0: 32 2d 66 22 0a 20 20 20 20 28 64 65 62 75 67 3a 2-f". (debug:
46c0: 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c print 18 *defaul
46d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 42 20 t-log-port* "DB
46e0: 53 74 61 74 73 5c 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 Stats\n========"
46f0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
4700: 6e 74 20 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c nt 18 *default-l
4710: 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 6d 61 74 og-port* (format
4720: 20 23 66 20 22 7e 34 30 61 7e 38 61 7e 31 30 61 #f "~40a~8a~10a
4730: 7e 31 30 61 22 20 22 43 6d 64 22 20 22 43 6f 75 ~10a" "Cmd" "Cou
4740: 6e 74 22 20 22 54 6f 74 54 69 6d 65 22 20 22 41 nt" "TotTime" "A
4750: 76 67 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 vg")). (for-e
4760: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 63 6d 64 ach (lambda (cmd
4770: 29 0a 09 09 28 6c 65 74 20 28 28 63 6d 64 2d 64 )...(let ((cmd-d
4780: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
4790: 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d ef *db-stats* cm
47a0: 64 29 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a d)))... (debug:
47b0: 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c print 18 *defaul
47c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 t-log-port* (for
47d0: 6d 61 74 20 23 66 20 66 6d 74 73 74 72 20 63 6d mat #f fmtstr cm
47e0: 64 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d d (vector-ref cm
47f0: 64 2d 64 61 74 20 30 29 20 28 76 65 63 74 6f 72 d-dat 0) (vector
4800: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 20 -ref cmd-dat 1)
4810: 28 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 (/ (vector-ref c
4820: 6d 64 2d 64 61 74 20 31 29 28 76 65 63 74 6f 72 md-dat 1)(vector
4830: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 29 -ref cmd-dat 0))
4840: 29 29 29 29 0a 09 20 20 20 20 20 20 28 73 6f 72 )))).. (sor
4850: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 t (hash-table-ke
4860: 79 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 0a 09 ys *db-stats*)..
4870: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 . (lambda (a
4880: 62 29 0a 09 09 20 20 20 20 20 20 28 3e 20 28 76 b)... (> (v
4890: 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 2d ector-ref (hash-
48a0: 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 table-ref *db-st
48b0: 61 74 73 2a 20 61 29 20 30 29 0a 09 09 09 20 28 ats* a) 0).... (
48c0: 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 vector-ref (hash
48d0: 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 -table-ref *db-s
48e0: 74 61 74 73 2a 20 62 29 20 30 29 29 29 29 29 29 tats* b) 0))))))
48f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
4900: 67 65 74 2d 6d 61 78 2d 71 75 65 72 79 2d 61 76 get-max-query-av
4910: 65 72 61 67 65 20 72 75 6e 2d 69 64 29 0a 20 20 erage run-id).
4920: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
4930: 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 -stats-mutex*).
4940: 20 28 6c 65 74 2a 20 28 28 72 75 6e 6b 65 79 20 (let* ((runkey
4950: 28 63 6f 6e 63 20 22 72 75 6e 2d 69 64 3d 22 20 (conc "run-id="
4960: 72 75 6e 2d 69 64 20 22 20 22 29 29 0a 09 20 28 run-id " ")).. (
4970: 63 6d 64 73 20 20 20 28 66 69 6c 74 65 72 20 28 cmds (filter (
4980: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 20 20 lambda (x)....
4990: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
49a0: 78 20 72 75 6e 6b 65 79 20 78 29 29 0a 09 09 09 x runkey x))....
49b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
49c0: 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 29 29 0a s *db-stats*))).
49d0: 09 20 28 72 65 73 20 20 20 20 28 69 66 20 28 6e . (res (if (n
49e0: 75 6c 6c 3f 20 63 6d 64 73 29 0a 09 09 20 20 20 ull? cmds)...
49f0: 20 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 (cons 'none 0)
4a00: 0a 09 09 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ... (let loo
4a10: 70 20 28 28 63 6d 64 20 28 63 61 72 20 63 6d 64 p ((cmd (car cmd
4a20: 73 29 29 0a 09 09 09 09 28 74 61 6c 20 28 63 64 s)).....(tal (cd
4a30: 72 20 63 6d 64 73 29 29 0a 09 09 09 09 28 6d 61 r cmds)).....(ma
4a40: 78 2d 63 6d 64 20 28 63 61 72 20 63 6d 64 73 29 x-cmd (car cmds)
4a50: 29 0a 09 09 09 09 28 72 65 73 20 30 29 29 0a 09 ).....(res 0))..
4a60: 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
4a70: 63 6d 64 2d 64 61 74 20 28 68 61 73 68 2d 74 61 cmd-dat (hash-ta
4a80: 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 ble-ref *db-stat
4a90: 73 2a 20 63 6d 64 29 29 0a 09 09 09 20 20 20 20 s* cmd))....
4aa0: 20 20 28 74 6f 74 20 20 20 20 20 28 76 65 63 74 (tot (vect
4ab0: 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 or-ref cmd-dat 0
4ac0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 63 75 72 )).... (cur
4ad0: 72 61 76 67 20 28 2f 20 28 76 65 63 74 6f 72 2d ravg (/ (vector-
4ae0: 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 20 28 ref cmd-dat 1) (
4af0: 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 vector-ref cmd-d
4b00: 61 74 20 30 29 29 29 20 3b 3b 20 63 6f 75 6e 74 at 0))) ;; count
4b10: 20 69 73 20 6e 65 76 65 72 20 7a 65 72 6f 20 62 is never zero b
4b20: 79 20 63 6f 6e 73 74 72 75 63 74 69 6f 6e 0a 09 y construction..
4b30: 09 09 20 20 20 20 20 20 28 63 75 72 72 6d 61 78 .. (currmax
4b40: 20 28 6d 61 78 20 72 65 73 20 63 75 72 72 61 76 (max res currav
4b50: 67 29 29 0a 09 09 09 20 20 20 20 20 20 28 6e 65 g)).... (ne
4b60: 77 6d 61 78 2d 63 6d 64 20 28 69 66 20 28 3e 20 wmax-cmd (if (>
4b70: 63 75 72 72 61 76 67 20 72 65 73 29 20 63 6d 64 curravg res) cmd
4b80: 20 6d 61 78 2d 63 6d 64 29 29 29 0a 09 09 09 20 max-cmd)))....
4b90: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
4ba0: 09 09 09 20 20 20 20 20 28 69 66 20 28 3e 20 74 ... (if (> t
4bb0: 6f 74 20 31 30 29 0a 09 09 09 09 20 28 63 6f 6e ot 10)..... (con
4bc0: 73 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 s newmax-cmd cur
4bd0: 72 6d 61 78 29 0a 09 09 09 09 20 28 63 6f 6e 73 rmax)..... (cons
4be0: 20 27 6e 6f 6e 65 20 30 29 29 0a 09 09 09 20 20 'none 0))....
4bf0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4c00: 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 6d l)(cdr tal) newm
4c10: 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 29 29 ax-cmd currmax))
4c20: 29 29 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 ))))). (mutex
4c30: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 -unlock! *db-sta
4c40: 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 ts-mutex*). r
4c50: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 es))..(define (r
4c60: 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 mt:open-qry-clos
4c70: 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 e-locally cmd ru
4c80: 6e 2d 69 64 20 70 61 72 61 6d 73 20 23 21 6b 65 n-id params #!ke
4c90: 79 20 28 72 65 6d 72 65 74 72 69 65 73 20 35 29 y (remretries 5)
4ca0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 71 72 79 2d ). (let* ((qry-
4cb0: 69 73 2d 77 72 69 74 65 20 20 20 20 28 6e 6f 74 is-write (not
4cc0: 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 (member cmd api
4cd0: 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 :read-only-queri
4ce0: 65 73 29 29 29 0a 09 20 28 64 62 2d 66 69 6c 65 es))).. (db-file
4cf0: 2d 70 61 74 68 20 20 20 20 28 64 62 3a 64 62 66 -path (db:dbf
4d00: 69 6c 65 2d 70 61 74 68 29 29 20 3b 3b 20 20 30 ile-path)) ;; 0
4d10: 29 29 0a 09 20 28 64 62 73 74 72 75 63 74 73 2d )).. (dbstructs-
4d20: 6c 6f 63 61 6c 20 28 64 62 3a 73 65 74 75 70 20 local (db:setup
4d30: 23 74 29 29 20 20 3b 3b 20 6d 61 6b 65 2d 64 62 #t)) ;; make-db
4d40: 72 3a 64 62 73 74 72 75 63 74 20 70 61 74 68 3a r:dbstruct path:
4d50: 20 20 64 62 64 69 72 20 6c 6f 63 61 6c 3a 20 23 dbdir local: #
4d60: 74 29 29 29 0a 09 20 28 72 65 61 64 2d 6f 6e 6c t))).. (read-onl
4d70: 79 20 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 y (not (fi
4d80: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
4d90: 20 64 62 2d 66 69 6c 65 2d 70 61 74 68 29 29 29 db-file-path)))
4da0: 0a 09 20 28 73 74 61 72 74 20 20 20 20 20 20 20 .. (start
4db0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c (current-mil
4dc0: 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 72 liseconds)).. (r
4dd0: 65 73 64 61 74 20 20 20 20 20 20 20 20 20 20 28 esdat (
4de0: 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 72 65 61 if (not (and rea
4df0: 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 73 2d 77 72 d-only qry-is-wr
4e00: 69 74 65 29 29 0a 09 09 09 20 20 20 20 20 20 28 ite)).... (
4e10: 6c 65 74 20 28 28 76 20 28 61 70 69 3a 65 78 65 let ((v (api:exe
4e20: 63 75 74 65 2d 72 65 71 75 65 73 74 73 20 64 62 cute-requests db
4e30: 73 74 72 75 63 74 73 2d 6c 6f 63 61 6c 20 28 76 structs-local (v
4e40: 65 63 74 6f 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 ector (symbol->s
4e50: 74 72 69 6e 67 20 63 6d 64 29 20 70 61 72 61 6d tring cmd) param
4e60: 73 29 29 29 29 0a 09 09 09 3b 3b 09 28 68 61 6e s))))....;;.(han
4e70: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 3b dle-exceptions ;
4e80: 3b 20 74 68 65 72 65 20 68 61 73 20 62 65 65 6e ; there has been
4e90: 20 61 20 6c 6f 6e 67 20 68 69 73 74 6f 72 79 20 a long history
4ea0: 6f 66 20 72 65 63 65 69 76 69 6e 67 20 73 74 72 of receiving str
4eb0: 61 6e 67 65 20 65 72 72 6f 72 73 20 66 72 6f 6d ange errors from
4ec0: 20 76 61 6c 75 65 73 20 72 65 74 75 72 6e 65 64 values returned
4ed0: 20 62 79 20 74 68 65 20 63 6c 69 65 6e 74 20 77 by the client w
4ee0: 68 65 6e 20 74 68 69 6e 67 73 20 67 6f 20 77 72 hen things go wr
4ef0: 6f 6e 67 2e 2e 0a 09 09 09 3b 3b 09 20 65 78 6e ong......;;. exn
4f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
4f10: 3b 20 20 54 68 69 73 20 69 73 20 61 6e 20 61 74 ; This is an at
4f20: 74 65 6d 70 74 20 74 6f 20 64 65 74 65 63 74 20 tempt to detect
4f30: 74 68 61 74 20 73 69 74 75 61 74 69 6f 6e 20 61 that situation a
4f40: 6e 64 20 72 65 63 6f 76 65 72 20 67 72 61 63 65 nd recover grace
4f50: 66 75 6c 6c 79 0a 09 09 09 3b 3b 09 20 28 62 65 fully....;;. (be
4f60: 67 69 6e 0a 09 09 09 3b 3b 09 20 20 20 28 64 65 gin....;;. (de
4f70: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4f80: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4f90: 45 52 52 4f 52 3a 20 62 61 64 20 64 61 74 61 20 ERROR: bad data
4fa0: 66 72 6f 6d 20 73 65 72 76 65 72 20 22 20 76 20 from server " v
4fb0: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 20 28 28 " message: " ((
4fc0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
4fd0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
4fe0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 'message) exn)
4ff0: 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 ", exn=" exn)...
5000: 09 3b 3b 09 20 20 20 28 76 65 63 74 6f 72 20 23 .;;. (vector #
5010: 74 20 27 28 29 29 29 20 3b 3b 20 73 68 6f 75 6c t '())) ;; shoul
5020: 64 20 61 6c 77 61 79 73 20 67 65 74 20 61 20 76 d always get a v
5030: 65 63 74 6f 72 20 62 75 74 20 69 66 20 73 6f 6d ector but if som
5040: 65 74 68 69 6e 67 20 67 6f 65 73 20 77 72 6f 6e ething goes wron
5050: 67 20 72 65 74 75 72 6e 20 61 20 64 75 6d 6d 79 g return a dummy
5060: 0a 09 09 09 09 20 28 69 66 20 28 61 6e 64 20 28 ..... (if (and (
5070: 76 65 63 74 6f 72 3f 20 76 29 0a 09 09 09 09 09 vector? v)......
5080: 20 20 28 3e 20 28 76 65 63 74 6f 72 2d 6c 65 6e (> (vector-len
5090: 67 74 68 20 76 29 20 31 29 29 0a 09 09 09 09 20 gth v) 1)).....
50a0: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 65 (let ((newve
50b0: 63 20 28 76 65 63 74 6f 72 20 28 76 65 63 74 6f c (vector (vecto
50c0: 72 2d 72 65 66 20 76 20 30 29 28 76 65 63 74 6f r-ref v 0)(vecto
50d0: 72 2d 72 65 66 20 76 20 31 29 29 29 29 0a 09 09 r-ref v 1))))...
50e0: 09 09 20 20 20 20 20 20 20 6e 65 77 76 65 63 29 .. newvec)
50f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 62 79 ;; by
5100: 20 63 6f 70 79 69 6e 67 20 74 68 65 20 76 65 63 copying the vec
5110: 74 6f 72 20 77 68 69 6c 65 20 69 6e 73 69 64 65 tor while inside
5120: 20 74 68 65 20 65 72 72 6f 72 20 68 61 6e 64 6c the error handl
5130: 65 72 20 77 65 20 73 68 6f 75 6c 64 20 66 6f 72 er we should for
5140: 63 65 20 74 68 65 20 64 65 74 65 63 74 69 6f 6e ce the detection
5150: 20 6f 66 20 61 20 63 6f 72 72 75 70 74 65 64 20 of a corrupted
5160: 72 65 63 6f 72 64 0a 09 09 09 09 20 20 20 20 20 record.....
5170: 28 76 65 63 74 6f 72 20 23 74 20 27 28 29 29 29 (vector #t '()))
5180: 29 20 3b 3b 20 29 20 20 3b 3b 20 77 65 20 63 6f ) ;; ) ;; we co
5190: 75 6c 64 20 61 6c 73 6f 20 63 68 65 63 6b 20 74 uld also check t
51a0: 68 61 74 20 74 68 65 20 72 65 74 75 72 6e 65 64 hat the returned
51b0: 20 74 79 70 65 73 20 61 72 65 20 76 61 6c 69 64 types are valid
51c0: 0a 09 09 09 20 20 20 20 20 20 28 76 65 63 74 6f .... (vecto
51d0: 72 20 23 74 20 27 28 29 29 29 29 0a 09 20 28 73 r #t '()))).. (s
51e0: 75 63 63 65 73 73 20 20 20 20 20 20 20 20 28 76 uccess (v
51f0: 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 ector-ref resdat
5200: 20 30 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 0)).. (res
5210: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
5220: 65 66 20 72 65 73 64 61 74 20 31 29 29 0a 09 20 ef resdat 1))..
5230: 28 64 75 72 61 74 69 6f 6e 20 20 20 20 20 20 20 (duration
5240: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
5250: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 29 iseconds) start)
5260: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
5270: 72 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 73 read-only qry-is
5280: 2d 77 72 69 74 65 29 0a 20 20 20 20 20 20 20 20 -write).
5290: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
52a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
52b0: 2a 20 22 45 52 52 4f 52 3a 20 61 74 74 65 6d 70 * "ERROR: attemp
52c0: 74 20 74 6f 20 77 72 69 74 65 20 74 6f 20 72 65 t to write to re
52d0: 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 73 65 ad-only database
52e0: 20 69 67 6e 6f 72 65 64 2e 20 63 6d 64 3d 22 20 ignored. cmd="
52f0: 63 6d 64 29 29 0a 20 20 20 20 28 69 66 20 28 6e cmd)). (if (n
5300: 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 69 66 ot success)..(if
5310: 20 28 3e 20 72 65 6d 72 65 74 72 69 65 73 20 30 (> remretries 0
5320: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
5330: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
5340: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
5350: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f lt-log-port* "lo
5360: 63 61 6c 20 71 75 65 72 79 20 66 61 69 6c 65 64 cal query failed
5370: 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e 2e 22 . Trying again."
5380: 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 ).. (thread
5390: 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 6e 64 -sleep! (/ (rand
53a0: 6f 6d 20 35 30 30 30 29 20 31 30 30 30 29 29 20 om 5000) 1000))
53b0: 3b 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d 20 64 ;; some random d
53c0: 65 6c 61 79 20 0a 09 20 20 20 20 20 20 28 72 6d elay .. (rm
53d0: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
53e0: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 6e -locally cmd run
53f0: 2d 69 64 20 70 61 72 61 6d 73 20 72 65 6d 72 65 -id params remre
5400: 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 72 65 74 tries: (- remret
5410: 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 28 ries 1))).. (
5420: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
5430: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
5440: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5450: 6f 72 74 2a 20 22 74 6f 6f 20 6d 61 6e 79 20 72 ort* "too many r
5460: 65 74 72 69 65 73 20 69 6e 20 72 6d 74 3a 6f 70 etries in rmt:op
5470: 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 en-qry-close-loc
5480: 61 6c 6c 79 2c 20 67 69 76 69 6e 67 20 75 70 22 ally, giving up"
5490: 29 0a 09 20 20 20 20 20 20 23 66 29 29 0a 09 28 ).. #f))..(
54a0: 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 72 6d 74 begin.. ;; (rmt
54b0: 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 74 73 :update-db-stats
54c0: 20 72 75 6e 2d 69 64 20 63 6d 64 20 70 61 72 61 run-id cmd para
54d0: 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 09 20 20 ms duration)..
54e0: 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 72 75 6e ;; mark this run
54f0: 20 61 73 20 64 69 72 74 79 20 69 66 20 74 68 69 as dirty if thi
5500: 73 20 77 61 73 20 61 20 77 72 69 74 65 2c 20 74 s was a write, t
5510: 68 65 20 77 61 74 63 68 64 6f 67 20 69 73 20 72 he watchdog is r
5520: 65 73 70 6f 6e 73 69 62 6c 65 20 66 6f 72 20 73 esponsible for s
5530: 79 6e 63 69 6e 67 20 69 74 0a 09 20 20 28 69 66 yncing it.. (if
5540: 20 71 72 79 2d 69 73 2d 77 72 69 74 65 0a 09 20 qry-is-write..
5550: 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 (let ((star
5560: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
5570: 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 6d 75 seconds)))...(mu
5580: 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 tex-lock! *db-mu
5590: 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 lti-sync-mutex*)
55a0: 0a 2f 09 09 28 73 65 74 21 20 2a 64 62 2d 6c 61 ./..(set! *db-la
55b0: 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 72 74 st-access* start
55c0: 2d 74 69 6d 65 29 20 20 3b 3b 20 54 48 49 53 20 -time) ;; THIS
55d0: 49 53 20 50 52 4f 42 41 42 4c 59 20 55 53 45 4c IS PROBABLY USEL
55e0: 45 53 53 3f 20 28 77 65 20 61 72 65 20 6f 6e 20 ESS? (we are on
55f0: 61 20 63 6c 69 65 6e 74 29 0a 20 20 20 20 20 20 a client).
5600: 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 (mutex
5610: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c -unlock! *db-mul
5620: 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 29 ti-sync-mutex*))
5630: 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 ))). res))..(
5640: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e 64 define (rmt:send
5650: 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 6f -receive-no-auto
5660: 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f -client-setup co
5670: 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d nnection-info cm
5680: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 d run-id params)
5690: 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 . (let* ((run-i
56a0: 64 20 20 20 28 69 66 20 72 75 6e 2d 69 64 20 72 d (if run-id r
56b0: 75 6e 2d 69 64 20 30 29 29 0a 09 20 28 72 65 73 un-id 0)).. (res
56c0: 20 20 09 20 20 20 3b 3b 20 28 68 61 6e 64 6c 65 . ;; (handle
56d0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 -exceptions...
56e0: 20 3b 3b 20 20 20 20 20 65 78 6e 0a 09 09 20 20 ;; exn...
56f0: 20 3b 3b 20 20 20 28 62 65 67 69 6e 0a 09 09 20 ;; (begin...
5700: 20 20 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 ;; (print
5710: 22 74 72 61 6e 73 70 6f 72 74 20 66 61 69 6c 65 "transport faile
5720: 64 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 d. exn=" exn)...
5730: 20 20 20 3b 3b 20 20 20 20 20 23 66 29 0a 09 09 ;; #f)...
5740: 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 (http-trans
5750: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d port:client-api-
5760: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e send-receive run
5770: 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 -id connection-i
5780: 6e 66 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 29 nfo cmd params))
5790: 29 20 3b 3b 20 29 0a 20 20 20 20 28 69 66 20 28 ) ;; ). (if (
57a0: 61 6e 64 20 72 65 73 20 28 76 65 63 74 6f 72 2d and res (vector-
57b0: 72 65 66 20 72 65 73 20 30 29 29 0a 09 28 76 65 ref res 0))..(ve
57c0: 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 ctor-ref res 1)
57d0: 3b 3b 3b 20 59 45 53 21 21 20 54 48 49 53 20 49 ;;; YES!! THIS I
57e0: 53 20 43 4f 52 52 45 43 54 21 21 20 43 48 41 4e S CORRECT!! CHAN
57f0: 47 45 20 49 54 20 48 45 52 45 2c 20 54 48 45 4e GE IT HERE, THEN
5800: 20 43 48 41 4e 47 45 20 72 6d 74 3a 73 65 6e 64 CHANGE rmt:send
5810: 2d 72 65 63 65 69 76 65 20 41 4c 53 4f 21 21 21 -receive ALSO!!!
5820: 0a 09 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d ..#f)))..;;=====
5830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5870: 3d 0a 3b 3b 0a 3b 3b 20 41 20 43 20 54 20 55 20 =.;;.;; A C T U
5880: 41 20 4c 20 20 20 41 20 50 20 49 20 20 20 43 20 A L A P I C
5890: 41 20 4c 20 4c 20 53 20 20 0a 3b 3b 0a 3b 3b 3d A L L S .;;.;;=
58a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58e0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d =====..;;=======
58f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5930: 3b 3b 20 20 53 20 45 20 52 20 56 20 45 20 52 0a ;; S E R V E R.
5940: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
5950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5980: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
5990: 65 20 28 72 6d 74 3a 6b 69 6c 6c 2d 73 65 72 76 e (rmt:kill-serv
59a0: 65 72 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d er run-id). (rm
59b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
59c0: 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 75 6e 2d kill-server run-
59d0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 id (list run-id)
59e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
59f0: 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 :start-server ru
5a00: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
5a10: 64 2d 72 65 63 65 69 76 65 20 27 73 74 61 72 74 d-receive 'start
5a20: 2d 73 65 72 76 65 72 20 30 20 28 6c 69 73 74 20 -server 0 (list
5a30: 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d run-id)))..;;===
5a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a80: 3d 3d 3d 0a 3b 3b 20 20 4d 20 49 20 53 20 43 0a ===.;; M I S C.
5a90: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
5aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ad0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
5ae0: 65 20 28 72 6d 74 3a 6c 6f 67 69 6e 20 72 75 6e e (rmt:login run
5af0: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
5b00: 2d 72 65 63 65 69 76 65 20 27 6c 6f 67 69 6e 20 -receive 'login
5b10: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 2a 74 6f run-id (list *to
5b20: 70 70 61 74 68 2a 20 6d 65 67 61 74 65 73 74 2d ppath* megatest-
5b30: 76 65 72 73 69 6f 6e 20 28 63 6c 69 65 6e 74 3a version (client:
5b40: 67 65 74 2d 73 69 67 6e 61 74 75 72 65 29 29 29 get-signature)))
5b50: 29 0a 0a 3b 3b 20 54 68 69 73 20 6c 6f 67 69 6e )..;; This login
5b60: 20 64 6f 65 73 20 6e 6f 20 72 65 74 72 69 65 73 does no retries
5b70: 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 20 under the hood
5b80: 2d 20 69 74 20 61 63 74 73 20 61 20 62 69 74 20 - it acts a bit
5b90: 6c 69 6b 65 20 61 20 70 69 6e 67 2e 0a 3b 3b 20 like a ping..;;
5ba0: 44 65 70 72 65 63 61 74 65 64 20 66 6f 72 20 6e Deprecated for n
5bb0: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 2e 0a 3b msg-transport..;
5bc0: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6c ;.(define (rmt:l
5bd0: 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 ogin-no-auto-cli
5be0: 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e 6e 65 63 ent-setup connec
5bf0: 74 69 6f 6e 2d 69 6e 66 6f 29 0a 20 20 28 63 61 tion-info). (ca
5c00: 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 se *transport-ty
5c10: 70 65 2a 20 3b 3b 20 72 75 6e 2d 69 64 20 6f 66 pe* ;; run-id of
5c20: 20 30 20 69 73 20 6a 75 73 74 20 61 20 70 6c 61 0 is just a pla
5c30: 63 65 68 6f 6c 64 65 72 0a 20 20 20 20 28 28 68 ceholder. ((h
5c40: 74 74 70 29 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ttp)(rmt:send-re
5c50: 63 65 69 76 65 2d 6e 6f 2d 61 75 74 6f 2d 63 6c ceive-no-auto-cl
5c60: 69 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e 6e 65 ient-setup conne
5c70: 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c 6f 67 69 ction-info 'logi
5c80: 6e 20 30 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 n 0 (list *toppa
5c90: 74 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 th* megatest-ver
5ca0: 73 69 6f 6e 20 28 63 6c 69 65 6e 74 3a 67 65 74 sion (client:get
5cb0: 2d 73 69 67 6e 61 74 75 72 65 29 29 29 29 0a 20 -signature)))).
5cc0: 20 20 20 3b 3b 28 28 6e 6d 73 67 29 28 6e 6d 73 ;;((nmsg)(nms
5cd0: 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 g-transport:clie
5ce0: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
5cf0: 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 ive run-id conne
5d00: 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c 6f 67 69 ction-info 'logi
5d10: 6e 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 n (list *toppath
5d20: 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 * megatest-versi
5d30: 6f 6e 20 72 75 6e 2d 69 64 20 2a 6d 79 2d 63 6c on run-id *my-cl
5d40: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 ient-signature*)
5d50: 29 29 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 68 61 )). ))..;; ha
5d60: 6e 64 20 6f 66 66 20 61 20 63 61 6c 6c 20 74 6f nd off a call to
5d70: 20 6f 6e 65 20 6f 66 20 74 68 65 20 64 62 3a 71 one of the db:q
5d80: 75 65 72 69 65 73 20 73 74 61 74 65 6d 65 6e 74 ueries statement
5d90: 73 0a 3b 3b 20 61 64 64 65 64 20 72 75 6e 2d 69 s.;; added run-i
5da0: 64 20 74 6f 20 6d 61 6b 65 20 6c 6f 6f 6b 69 6e d to make lookin
5db0: 67 20 75 70 20 74 68 65 20 63 6f 72 72 65 63 74 g up the correct
5dc0: 20 64 62 20 70 6f 73 73 69 62 6c 65 20 0a 3b 3b db possible .;;
5dd0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
5de0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 73 74 6d 74 6e neral-call stmtn
5df0: 61 6d 65 20 72 75 6e 2d 69 64 20 2e 20 70 61 72 ame run-id . par
5e00: 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ams). (rmt:send
5e10: 2d 72 65 63 65 69 76 65 20 27 67 65 6e 65 72 61 -receive 'genera
5e20: 6c 2d 63 61 6c 6c 20 72 75 6e 2d 69 64 20 28 61 l-call run-id (a
5e30: 70 70 65 6e 64 20 28 6c 69 73 74 20 73 74 6d 74 ppend (list stmt
5e40: 6e 61 6d 65 20 72 75 6e 2d 69 64 29 20 70 61 72 name run-id) par
5e50: 61 6d 73 29 29 29 0a 0a 0a 3b 3b 20 67 69 76 65 ams)))...;; give
5e60: 6e 20 61 20 68 6f 73 74 6e 61 6d 65 2c 20 72 65 n a hostname, re
5e70: 74 75 72 6e 20 61 20 70 61 69 72 20 6f 66 20 63 turn a pair of c
5e80: 70 75 20 6c 6f 61 64 20 61 6e 64 20 75 70 64 61 pu load and upda
5e90: 74 65 20 74 69 6d 65 20 72 65 70 72 65 73 65 6e te time represen
5ea0: 74 69 6e 67 20 6c 61 74 65 73 74 20 69 6e 74 65 ting latest inte
5eb0: 6c 6c 69 67 65 6e 63 65 20 66 72 6f 6d 20 74 65 lligence from te
5ec0: 73 74 73 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 sts running on t
5ed0: 68 61 74 20 68 6f 73 74 0a 28 64 65 66 69 6e 65 hat host.(define
5ee0: 20 28 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 (rmt:get-latest
5ef0: 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e -host-load hostn
5f00: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
5f10: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6c 61 -receive 'get-la
5f20: 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 30 test-host-load 0
5f30: 20 28 6c 69 73 74 20 68 6f 73 74 6e 61 6d 65 29 (list hostname)
5f40: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5f50: 3a 73 64 62 2d 71 72 79 20 71 72 79 20 76 61 6c :sdb-qry qry val
5f60: 20 72 75 6e 2d 69 64 29 0a 20 20 3b 3b 20 61 64 run-id). ;; ad
5f70: 64 20 63 61 63 68 69 6e 67 20 69 66 20 71 72 79 d caching if qry
5f80: 20 69 73 20 27 67 65 74 69 64 20 6f 72 20 27 67 is 'getid or 'g
5f90: 65 74 73 74 72 0a 20 20 28 72 6d 74 3a 73 65 6e etstr. (rmt:sen
5fa0: 64 2d 72 65 63 65 69 76 65 20 27 73 64 62 2d 71 d-receive 'sdb-q
5fb0: 72 79 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ry run-id (list
5fc0: 71 72 79 20 76 61 6c 29 29 29 0a 0a 3b 3b 20 4e qry val)))..;; N
5fd0: 4f 54 20 43 4f 4d 50 4c 45 54 45 44 0a 28 64 65 OT COMPLETED.(de
5fe0: 66 69 6e 65 20 28 72 6d 74 3a 72 75 6e 74 65 73 fine (rmt:runtes
5ff0: 74 73 20 75 73 65 72 20 72 75 6e 2d 69 64 20 74 ts user run-id t
6000: 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 29 0a estpatt params).
6010: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
6020: 69 76 65 20 27 72 75 6e 74 65 73 74 73 20 72 75 ive 'runtests ru
6030: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 29 29 0a n-id testpatt)).
6040: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
6050: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 73 t-run-record-ids
6060: 20 20 74 61 72 67 65 74 20 72 75 6e 20 6b 65 79 target run key
6070: 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 29 names test-patt)
6080: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
6090: 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 72 65 eive 'get-run-re
60a0: 63 6f 72 64 2d 69 64 73 20 23 66 20 28 6c 69 73 cord-ids #f (lis
60b0: 74 20 74 61 72 67 65 74 20 72 75 6e 20 6b 65 79 t target run key
60c0: 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 29 names test-patt)
60d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
60e0: 3a 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 65 63 :get-changed-rec
60f0: 6f 72 64 2d 69 64 73 20 73 69 6e 63 65 2d 74 69 ord-ids since-ti
6100: 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d me). (rmt:send-
6110: 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 68 61 receive 'get-cha
6120: 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 20 nged-record-ids
6130: 23 66 20 28 6c 69 73 74 20 73 69 6e 63 65 2d 74 #f (list since-t
6140: 69 6d 65 29 29 20 29 0a 0a 28 64 65 66 69 6e 65 ime)) )..(define
6150: 20 28 72 6d 74 3a 64 72 6f 70 2d 61 6c 6c 2d 74 (rmt:drop-all-t
6160: 72 69 67 67 65 72 73 29 0a 20 20 20 20 20 28 72 riggers). (r
6170: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
6180: 27 64 72 6f 70 2d 61 6c 6c 2d 74 72 69 67 67 65 'drop-all-trigge
6190: 72 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 rs #f '()))..(de
61a0: 66 69 6e 65 20 28 72 6d 74 3a 63 72 65 61 74 65 fine (rmt:create
61b0: 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 29 0a 20 -all-triggers).
61c0: 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 (rmt:send-re
61d0: 63 65 69 76 65 20 27 63 72 65 61 74 65 2d 61 6c ceive 'create-al
61e0: 6c 2d 74 72 69 67 67 65 72 73 20 23 66 20 27 28 l-triggers #f '(
61f0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
6200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
6240: 20 20 54 20 45 20 53 20 54 20 20 20 4d 20 45 20 T E S T M E
6250: 54 20 41 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T A .;;=========
6260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
62a0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
62b0: 74 65 73 74 73 2d 74 61 67 73 29 0a 20 20 28 72 tests-tags). (r
62c0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
62d0: 27 67 65 74 2d 74 65 73 74 73 2d 74 61 67 73 20 'get-tests-tags
62e0: 23 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d #f '()))..;;====
62f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6330: 3d 3d 0a 3b 3b 20 20 4b 20 45 20 59 20 53 20 0a ==.;; K E Y S .
6340: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6380: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 54 68 65 ========..;; The
6390: 73 65 20 72 65 71 75 69 72 65 20 72 75 6e 2d 69 se require run-i
63a0: 64 20 62 65 63 61 75 73 65 20 74 68 65 20 76 61 d because the va
63b0: 6c 75 65 73 20 63 6f 6d 65 20 66 72 6f 6d 20 74 lues come from t
63c0: 68 65 20 72 75 6e 21 0a 3b 3b 0a 28 64 65 66 69 he run!.;;.(defi
63d0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d ne (rmt:get-key-
63e0: 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 val-pairs run-id
63f0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
6400: 63 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 ceive 'get-key-v
6410: 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 20 al-pairs run-id
6420: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
6430: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
6440: 74 2d 6b 65 79 73 29 0a 20 20 28 69 66 20 2a 64 t-keys). (if *d
6450: 62 2d 6b 65 79 73 2a 20 2a 64 62 2d 6b 65 79 73 b-keys* *db-keys
6460: 2a 20 0a 20 20 20 20 20 28 6c 65 74 20 28 28 72 * . (let ((r
6470: 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 es (rmt:send-rec
6480: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 73 20 23 eive 'get-keys #
6490: 66 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 20 f '()))).
64a0: 28 73 65 74 21 20 2a 64 62 2d 6b 65 79 73 2a 20 (set! *db-keys*
64b0: 72 65 73 29 0a 20 20 20 20 20 20 20 72 65 73 29 res). res)
64c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
64d0: 3a 67 65 74 2d 6b 65 79 73 2d 77 72 69 74 65 29 :get-keys-write)
64e0: 20 3b 3b 20 64 75 6d 6d 79 20 71 75 65 72 79 20 ;; dummy query
64f0: 74 6f 20 66 6f 72 63 65 20 73 65 72 76 65 72 20 to force server
6500: 73 74 61 72 74 0a 20 20 28 6c 65 74 20 28 28 72 start. (let ((r
6510: 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 es (rmt:send-rec
6520: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 73 2d 77 eive 'get-keys-w
6530: 72 69 74 65 20 23 66 20 27 28 29 29 29 29 0a 20 rite #f '()))).
6540: 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6b 65 79 (set! *db-key
6550: 73 2a 20 72 65 73 29 0a 20 20 20 20 72 65 73 29 s* res). res)
6560: 29 0a 0a 3b 3b 20 77 65 20 64 6f 6e 27 74 20 72 )..;; we don't r
6570: 65 75 73 65 20 72 75 6e 2d 69 64 27 73 20 28 65 euse run-id's (e
6580: 78 63 65 70 74 20 70 6f 73 73 69 62 6c 79 20 2a xcept possibly *
6590: 61 66 74 65 72 2a 20 61 20 64 62 20 63 6c 65 61 after* a db clea
65a0: 6e 75 70 29 20 73 6f 20 69 74 20 69 73 20 73 61 nup) so it is sa
65b0: 66 65 0a 3b 3b 20 74 6f 20 63 61 63 68 65 20 74 fe.;; to cache t
65c0: 68 65 20 72 65 73 75 6c 73 20 69 6e 20 61 20 68 he resuls in a h
65d0: 61 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ash.;;.(define (
65e0: 72 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 rmt:get-key-vals
65f0: 20 72 75 6e 2d 69 64 29 0a 20 20 28 6f 72 20 28 run-id). (or (
6600: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
6610: 65 66 61 75 6c 74 20 2a 6b 65 79 76 61 6c 73 2a efault *keyvals*
6620: 20 72 75 6e 2d 69 64 20 23 66 29 0a 20 20 20 20 run-id #f).
6630: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 72 6d (let ((res (rm
6640: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
6650: 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 23 66 20 get-key-vals #f
6660: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 29 (list run-id))))
6670: 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 . (hash-t
6680: 61 62 6c 65 2d 73 65 74 21 20 2a 6b 65 79 76 61 able-set! *keyva
6690: 6c 73 2a 20 72 75 6e 2d 69 64 20 72 65 73 29 0a ls* run-id res).
66a0: 20 20 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a res)))..
66b0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
66c0: 2d 74 61 72 67 65 74 73 29 0a 20 20 28 72 6d 74 -targets). (rmt
66d0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
66e0: 65 74 2d 74 61 72 67 65 74 73 20 23 66 20 27 28 et-targets #f '(
66f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
6700: 74 3a 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e t:get-target run
6710: 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 -id). (assert (
6720: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
6730: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
6740: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
6750: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
6760: 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d 69 get-target run-i
6770: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 d (list run-id))
6780: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
6790: 67 65 74 2d 72 75 6e 2d 74 69 6d 65 73 20 72 75 get-run-times ru
67a0: 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 74 74 npatt targetpatt
67b0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
67c0: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 74 ceive 'get-run-t
67d0: 69 6d 65 73 20 23 66 20 28 6c 69 73 74 20 72 75 imes #f (list ru
67e0: 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 74 74 npatt targetpatt
67f0: 20 29 29 29 20 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))) ...;;======
6800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6840: 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 53 0a 3b .;; T E S T S.;
6850: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
6860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6890: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4a 75 73 74 =======..;; Just
68a0: 20 73 6f 6d 65 20 73 79 6e 74 61 74 69 63 20 73 some syntatic s
68b0: 75 67 61 72 0a 28 64 65 66 69 6e 65 20 28 72 6d ugar.(define (rm
68c0: 74 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 t:register-test
68d0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
68e0: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 61 item-path). (a
68f0: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
6900: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
6910: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
6920: 29 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c ). (rmt:general
6930: 2d 63 61 6c 6c 20 27 72 65 67 69 73 74 65 72 2d -call 'register-
6940: 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d test run-id run-
6950: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
6960: 6d 2d 70 61 74 68 29 29 0a 0a 28 64 65 66 69 6e m-path))..(defin
6970: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d e (rmt:get-test-
6980: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 id run-id testna
6990: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 me item-path).
69a0: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
69b0: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
69c0: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
69d0: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
69e0: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 receive 'get-tes
69f0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 t-id run-id (lis
6a00: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d t run-id testnam
6a10: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a e item-path)))..
6a20: 3b 3b 20 72 75 6e 2d 69 64 20 69 73 20 4e 4f 54 ;; run-id is NOT
6a30: 20 75 73 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 used.;;.(define
6a40: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
6a50: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
6a60: 20 74 65 73 74 2d 69 64 29 0a 20 20 28 69 66 20 test-id). (if
6a70: 28 6e 75 6d 62 65 72 3f 20 74 65 73 74 2d 69 64 (number? test-id
6a80: 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 65 6e ). (rmt:sen
6a90: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
6aa0: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 est-info-by-id r
6ab0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
6ac0: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 id test-id)).
6ad0: 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 (begin..(debu
6ae0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
6af0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
6b00: 52 4e 49 4e 47 3a 20 42 61 64 20 64 61 74 61 20 RNING: Bad data
6b10: 68 61 6e 64 65 64 20 74 6f 20 72 6d 74 3a 67 65 handed to rmt:ge
6b20: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
6b30: 64 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 d run-id=" run-i
6b40: 64 20 22 2c 20 74 65 73 74 2d 69 64 3d 22 20 74 d ", test-id=" t
6b50: 65 73 74 2d 69 64 29 0a 09 28 70 72 69 6e 74 2d est-id)..(print-
6b60: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
6b70: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
6b80: 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..#f)))..(define
6b90: 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 (rmt:test-get-r
6ba0: 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d undir-from-test-
6bb0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
6bc0: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
6bd0: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
6be0: 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 -rundir-from-tes
6bf0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 t-id run-id (lis
6c00: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
6c10: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
6c20: 74 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 2d 62 t:open-test-db-b
6c30: 79 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 y-test-id run-id
6c40: 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 28 test-id #!key (
6c50: 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 20 work-area #f)).
6c60: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
6c70: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
6c80: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
6c90: 64 2e 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 d."). (let* ((t
6ca0: 65 73 74 2d 70 61 74 68 20 28 69 66 20 28 73 74 est-path (if (st
6cb0: 72 69 6e 67 3f 20 77 6f 72 6b 2d 61 72 65 61 29 ring? work-area)
6cc0: 0a 09 09 09 77 6f 72 6b 2d 61 72 65 61 0a 09 09 ....work-area...
6cd0: 09 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 .(rmt:test-get-r
6ce0: 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d undir-from-test-
6cf0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
6d00: 64 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 d)))). (debug
6d10: 3a 70 72 69 6e 74 20 33 20 2a 64 65 66 61 75 6c :print 3 *defaul
6d20: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 45 53 t-log-port* "TES
6d30: 54 20 50 41 54 48 3a 20 22 20 74 65 73 74 2d 70 T PATH: " test-p
6d40: 61 74 68 29 0a 20 20 20 20 28 6f 70 65 6e 2d 74 ath). (open-t
6d50: 65 73 74 2d 64 62 20 74 65 73 74 2d 70 61 74 68 est-db test-path
6d60: 29 29 29 0a 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a )))..;; WARNING:
6d70: 20 54 68 69 73 20 63 75 72 72 65 6e 74 6c 79 20 This currently
6d80: 62 79 70 61 73 73 65 73 20 74 68 65 20 74 72 61 bypasses the tra
6d90: 6e 73 61 63 74 69 6f 6e 20 77 72 61 70 70 65 64 nsaction wrapped
6da0: 20 77 72 69 74 65 73 20 73 79 73 74 65 6d 0a 28 writes system.(
6db0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
6dc0: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
6dd0: 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 s-by-id run-id t
6de0: 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 est-id newstate
6df0: 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d newstatus newcom
6e00: 6d 65 6e 74 29 0a 20 20 28 61 73 73 65 72 74 20 ment). (assert
6e10: 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 (number? run-id)
6e20: 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 "FATAL: Run id
6e30: 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 required."). (r
6e40: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
6e50: 27 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 'test-set-state-
6e60: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
6e70: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
6e80: 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 test-id newstat
6e90: 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 e newstatus newc
6ea0: 6f 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 omment)))..(defi
6eb0: 6e 65 20 28 72 6d 74 3a 73 65 74 2d 74 65 73 74 ne (rmt:set-test
6ec0: 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 s-state-status r
6ed0: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 20 un-id testnames
6ee0: 63 75 72 72 73 74 61 74 65 20 63 75 72 72 73 74 currstate currst
6ef0: 61 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 atus newstate ne
6f00: 77 73 74 61 74 75 73 29 0a 20 20 28 61 73 73 65 wstatus). (asse
6f10: 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d rt (number? run-
6f20: 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 id) "FATAL: Run
6f30: 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 id required.").
6f40: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6f50: 76 65 20 27 73 65 74 2d 74 65 73 74 73 2d 73 74 ve 'set-tests-st
6f60: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
6f70: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
6f80: 65 73 74 6e 61 6d 65 73 20 63 75 72 72 73 74 61 estnames currsta
6f90: 74 65 20 63 75 72 72 73 74 61 74 75 73 20 6e 65 te currstatus ne
6fa0: 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 wstate newstatus
6fb0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
6fc0: 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
6fd0: 72 75 6e 20 72 75 6e 2d 69 64 20 74 65 73 74 70 run run-id testp
6fe0: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
6ff0: 73 65 73 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 ses offset limit
7000: 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 2d 62 79 20 not-in sort-by
7010: 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 61 sort-order qryva
7020: 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 6d ls last-update m
7030: 6f 64 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 ode). (assert (
7040: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
7050: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
7060: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 3b 3b 20 equired."). ;;
7070: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e (if (number? run
7080: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
7090: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
70a0: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d sts-for-run run-
70b0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
70c0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
70d0: 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 20 statuses offset
70e0: 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 limit not-in sor
70f0: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
7100: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
7110: 61 74 65 20 6d 6f 64 65 29 29 29 0a 20 20 3b 3b ate mode))). ;;
7120: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 09 (begin. ;;.
7130: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
7140: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
7150: 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 67 65 74 g-port* "rmt:get
7160: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 63 -tests-for-run c
7170: 61 6c 6c 65 64 20 77 69 74 68 20 62 61 64 20 72 alled with bad r
7180: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a un-id=" run-id).
7190: 20 20 3b 3b 09 28 70 72 69 6e 74 2d 63 61 6c 6c ;;.(print-call
71a0: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
71b0: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 3b error-port)). ;
71c0: 3b 09 27 28 29 29 29 29 0a 0a 28 64 65 66 69 6e ;.'())))..(defin
71d0: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 e (rmt:get-tests
71e0: 2d 66 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d 73 -for-run-state-s
71f0: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 tatus run-id tes
7200: 74 70 61 74 74 20 6c 61 73 74 2d 75 70 64 61 74 tpatt last-updat
7210: 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 e). (assert (nu
7220: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
7230: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
7240: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
7250: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
7260: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d t-tests-for-run-
7270: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
7280: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7290: 20 74 65 73 74 70 61 74 74 20 6c 61 73 74 2d 75 testpatt last-u
72a0: 70 64 61 74 65 29 29 29 0a 0a 3b 3b 20 67 65 74 pdate)))..;; get
72b0: 20 73 74 75 66 66 20 76 69 61 20 73 79 6e 63 68 stuff via synch
72c0: 61 73 68 20 0a 28 64 65 66 69 6e 65 20 28 72 6d ash .(define (rm
72d0: 74 3a 73 79 6e 63 68 61 73 68 2d 67 65 74 20 72 t:synchash-get r
72e0: 75 6e 2d 69 64 20 70 72 6f 63 20 73 79 6e 63 6b un-id proc synck
72f0: 65 79 20 6b 65 79 6e 75 6d 20 70 61 72 61 6d 73 ey keynum params
7300: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
7310: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
7320: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
7330: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 ired."). (rmt:s
7340: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 79 6e end-receive 'syn
7350: 63 68 61 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 chash-get run-id
7360: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 70 72 (list run-id pr
7370: 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 oc synckey keynu
7380: 6d 20 70 61 72 61 6d 73 29 29 29 0a 0a 28 64 65 m params)))..(de
7390: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 fine (rmt:get-te
73a0: 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 sts-for-run-mind
73b0: 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 70 ata run-id testp
73c0: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
73d0: 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 61 73 73 s not-in). (ass
73e0: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
73f0: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
7400: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
7410: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7420: 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d 66 ive 'get-tests-f
7430: 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 or-run-mindata r
7440: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
7450: 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 id testpatt stat
7460: 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e es status not-in
7470: 29 29 29 0a 20 20 0a 3b 3b 20 49 44 45 41 3a 20 ))). .;; IDEA:
7480: 54 68 72 65 61 64 69 66 79 20 74 68 65 73 65 20 Threadify these
7490: 2d 20 74 68 65 79 20 73 70 65 6e 64 20 61 20 6c - they spend a l
74a0: 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 69 74 69 ot of time waiti
74b0: 6e 67 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 6e ng ....;;.(defin
74c0: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 e (rmt:get-tests
74d0: 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 -for-runs-mindat
74e0: 61 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 61 a run-ids testpa
74f0: 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 tt states status
7500: 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 6c 65 74 20 not-in). (let
7510: 28 28 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 ((multi-run-mute
7520: 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a x (make-mutex)).
7530: 09 28 72 75 6e 2d 69 64 2d 6c 69 73 74 20 28 69 .(run-id-list (i
7540: 66 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 72 75 f run-ids.... ru
7550: 6e 2d 69 64 73 0a 09 09 09 20 28 72 6d 74 3a 67 n-ids.... (rmt:g
7560: 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 et-all-run-ids))
7570: 29 0a 09 28 72 65 73 75 6c 74 20 20 20 20 20 20 )..(result
7580: 27 28 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e '())). (if (n
7590: 75 6c 6c 3f 20 72 75 6e 2d 69 64 2d 6c 69 73 74 ull? run-id-list
75a0: 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f 6f )..'()..(let loo
75b0: 70 20 28 28 68 65 64 20 20 20 20 20 28 63 61 72 p ((hed (car
75c0: 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 0a 09 run-id-list))..
75d0: 09 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 . (tal (cd
75e0: 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 0a r run-id-list)).
75f0: 09 09 20 20 20 28 74 68 72 65 61 64 73 20 27 28 .. (threads '(
7600: 29 29 29 0a 09 20 20 28 69 66 20 28 3e 20 28 6c ))).. (if (> (l
7610: 65 6e 67 74 68 20 74 68 72 65 61 64 73 29 20 35 ength threads) 5
7620: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 68 ).. (loop h
7630: 65 64 20 74 61 6c 20 28 66 69 6c 74 65 72 20 28 ed tal (filter (
7640: 6c 61 6d 62 64 61 20 28 74 68 29 28 6e 6f 74 20 lambda (th)(not
7650: 28 6d 65 6d 62 65 72 20 28 74 68 72 65 61 64 2d (member (thread-
7660: 73 74 61 74 65 20 74 68 29 20 27 28 74 65 72 6d state th) '(term
7670: 69 6e 61 74 65 64 20 64 65 61 64 29 29 29 29 20 inated dead))))
7680: 74 68 72 65 61 64 73 29 29 0a 09 20 20 20 20 20 threads))..
7690: 20 28 6c 65 74 2a 20 28 28 6e 65 77 74 68 72 65 (let* ((newthre
76a0: 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a ad (make-thread.
76b0: 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a .... (lambda ().
76c0: 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 72 65 .... (let ((re
76d0: 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 s (rmt:send-rece
76e0: 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d 66 ive 'get-tests-f
76f0: 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 68 or-run-mindata h
7700: 65 64 20 28 6c 69 73 74 20 68 65 64 20 74 65 73 ed (list hed tes
7710: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
7720: 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 29 0a 09 tus not-in))))..
7730: 09 09 09 20 20 20 20 20 28 69 66 20 28 6c 69 73 ... (if (lis
7740: 74 3f 20 72 65 73 29 0a 09 09 09 09 09 20 28 62 t? res)...... (b
7750: 65 67 69 6e 0a 09 09 09 09 09 20 20 20 28 6d 75 egin...... (mu
7760: 74 65 78 2d 6c 6f 63 6b 21 20 6d 75 6c 74 69 2d tex-lock! multi-
7770: 72 75 6e 2d 6d 75 74 65 78 29 0a 09 09 09 09 09 run-mutex)......
7780: 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
7790: 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 72 (append result r
77a0: 65 73 29 29 0a 09 09 09 09 09 20 20 20 28 6d 75 es))...... (mu
77b0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 75 6c 74 tex-unlock! mult
77c0: 69 2d 72 75 6e 2d 6d 75 74 65 78 29 29 0a 09 09 i-run-mutex))...
77d0: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
77e0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
77f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 65 74 t-log-port* "get
7800: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d -tests-for-run-m
7810: 69 6e 64 61 74 61 20 66 61 69 6c 65 64 20 66 6f indata failed fo
7820: 72 20 72 75 6e 2d 69 64 20 22 20 68 65 64 20 22 r run-id " hed "
7830: 2c 20 74 65 73 74 70 61 74 74 20 22 20 74 65 73 , testpatt " tes
7840: 74 70 61 74 74 20 22 2c 20 73 74 61 74 65 73 20 tpatt ", states
7850: 22 20 73 74 61 74 65 73 20 22 2c 20 73 74 61 74 " states ", stat
7860: 75 73 20 22 20 73 74 61 74 75 73 20 22 2c 20 6e us " status ", n
7870: 6f 74 2d 69 6e 20 22 20 6e 6f 74 2d 69 6e 29 29 ot-in " not-in))
7880: 29 29 0a 09 09 09 09 20 28 63 6f 6e 63 20 22 6d ))..... (conc "m
7890: 75 6c 74 69 2d 72 75 6e 2d 74 68 72 65 61 64 20 ulti-run-thread
78a0: 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 65 64 for run-id " hed
78b0: 29 29 29 0a 09 09 20 20 20 20 20 28 6e 65 77 74 )))... (newt
78c0: 68 72 65 61 64 73 20 28 63 6f 6e 73 20 6e 65 77 hreads (cons new
78d0: 74 68 72 65 61 64 20 74 68 72 65 61 64 73 29 29 thread threads))
78e0: 29 0a 09 09 28 74 68 72 65 61 64 2d 73 74 61 72 )...(thread-star
78f0: 74 21 20 6e 65 77 74 68 72 65 61 64 29 0a 09 09 t! newthread)...
7900: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
7910: 2e 30 35 29 20 3b 3b 20 67 69 76 65 20 74 68 61 .05) ;; give tha
7920: 74 20 74 68 72 65 61 64 20 73 6f 6d 65 20 74 69 t thread some ti
7930: 6d 65 20 74 6f 20 73 74 61 72 74 0a 09 09 28 69 me to start...(i
7940: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
7950: 20 20 20 20 6e 65 77 74 68 72 65 61 64 73 0a 09 newthreads..
7960: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
7970: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 tal)(cdr tal) ne
7980: 77 74 68 72 65 61 64 73 29 29 29 29 29 29 0a 20 wthreads)))))).
7990: 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 result))..;;
79a0: 3b 3b 20 49 44 45 41 3a 20 54 68 72 65 61 64 69 ;; IDEA: Threadi
79b0: 66 79 20 74 68 65 73 65 20 2d 20 74 68 65 79 20 fy these - they
79c0: 73 70 65 6e 64 20 61 20 6c 6f 74 20 6f 66 20 74 spend a lot of t
79d0: 69 6d 65 20 77 61 69 74 69 6e 67 20 2e 2e 2e 0a ime waiting ....
79e0: 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 ;; ;;.;; (define
79f0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d (rmt:get-tests-
7a00: 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 61 for-runs-mindata
7a10: 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 61 74 run-ids testpat
7a20: 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 t states status
7a30: 6e 6f 74 2d 69 6e 29 0a 3b 3b 20 20 20 28 6c 65 not-in).;; (le
7a40: 74 20 28 28 72 75 6e 2d 69 64 2d 6c 69 73 74 20 t ((run-id-list
7a50: 28 69 66 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 09 (if run-ids.;; .
7a60: 09 09 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 09 09 .. run-ids.;; ..
7a70: 09 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 . (rmt:get-all-r
7a80: 75 6e 2d 69 64 73 29 29 29 29 0a 3b 3b 20 20 20 un-ids)))).;;
7a90: 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 (apply append
7aa0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 (map (lambda (ru
7ab0: 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 20 28 72 6d n-id).;; ... (rm
7ac0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7ad0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
7ae0: 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 n-mindata run-id
7af0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 73 20 74 (list run-ids t
7b00: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
7b10: 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 0a tatus not-in))).
7b20: 3b 3b 20 09 09 20 20 20 20 20 20 20 72 75 6e 2d ;; .. run-
7b30: 69 64 2d 6c 69 73 74 29 29 29 29 0a 0a 28 64 65 id-list))))..(de
7b40: 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 fine (rmt:delete
7b50: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 75 -test-records ru
7b60: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
7b70: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
7b80: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
7b90: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
7ba0: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
7bb0: 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d receive 'delete-
7bc0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 75 6e test-records run
7bd0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7be0: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 test-id)))..(de
7bf0: 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 fine (rmt:test-s
7c00: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 et-state-status
7c10: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
7c20: 74 61 74 65 20 73 74 61 74 75 73 20 6d 73 67 29 tate status msg)
7c30: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
7c40: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
7c50: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
7c60: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
7c70: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
7c80: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
7c90: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
7ca0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 un-id test-id st
7cb0: 61 74 65 20 73 74 61 74 75 73 20 6d 73 67 29 29 ate status msg))
7cc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
7cd0: 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 test-toplevel-nu
7ce0: 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 m-items run-id t
7cf0: 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 61 73 73 est-name). (ass
7d00: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
7d10: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
7d20: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
7d30: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7d40: 69 76 65 20 27 74 65 73 74 2d 74 6f 70 6c 65 76 ive 'test-toplev
7d50: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
7d60: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7d70: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 3b test-name)))..;
7d80: 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ; (define (rmt:g
7d90: 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 et-previous-test
7da0: 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d -run-record run-
7db0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
7dc0: 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 72 6d m-path).;; (rm
7dd0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7de0: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
7df0: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
7e00: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7e10: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
7e20: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
7e30: 20 28 72 6d 74 3a 67 65 74 2d 6d 61 74 63 68 69 (rmt:get-matchi
7e40: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
7e50: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e -run-records run
7e60: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
7e70: 65 6d 2d 70 61 74 68 29 0a 20 20 28 61 73 73 65 em-path). (asse
7e80: 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d rt (number? run-
7e90: 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 id) "FATAL: Run
7ea0: 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 id required.").
7eb0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
7ec0: 76 65 20 27 67 65 74 2d 6d 61 74 63 68 69 6e 67 ve 'get-matching
7ed0: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
7ee0: 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 un-records run-i
7ef0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
7f00: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7f10: 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th)))..(define (
7f20: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 rmt:test-get-log
7f30: 66 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 file-info run-id
7f40: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 61 test-name). (a
7f50: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
7f60: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
7f70: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
7f80: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7f90: 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d ceive 'test-get-
7fa0: 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 75 6e logfile-info run
7fb0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7fc0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 test-name)))..(
7fd0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
7fe0: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
7ff0: 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d -index-file run-
8000: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 id test-name).
8010: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
8020: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
8030: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
8040: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
8050: 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 receive 'test-ge
8060: 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e t-records-for-in
8070: 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 dex-file run-id
8080: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
8090: 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 t-name)))..(defi
80a0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
80b0: 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 info-state-statu
80c0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
80d0: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
80e0: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
80f0: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
8100: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 ired."). (rmt:s
8110: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8120: 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d -testinfo-state-
8130: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c status run-id (l
8140: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
8150: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
8160: 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 6c 6f 67 rmt:test-set-log
8170: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
8180: 20 6c 6f 67 66 29 0a 20 20 28 61 73 73 65 72 74 logf). (assert
8190: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
81a0: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
81b0: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
81c0: 69 66 20 28 73 74 72 69 6e 67 3f 20 6c 6f 67 66 if (string? logf
81d0: 29 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 )(rmt:general-ca
81e0: 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d 6c 6f 67 ll 'test-set-log
81f0: 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 74 65 73 run-id logf tes
8200: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
8210: 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 74 (rmt:test-set-t
8220: 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 op-process-pid r
8230: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 70 69 un-id test-id pi
8240: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
8250: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
8260: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
8270: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
8280: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
8290: 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 st-set-top-proce
82a0: 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 28 6c ss-pid run-id (l
82b0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
82c0: 69 64 20 70 69 64 29 29 29 0a 0a 28 64 65 66 69 id pid)))..(defi
82d0: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ne (rmt:test-get
82e0: 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 -top-process-pid
82f0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
8300: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
8310: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
8320: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
8330: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
8340: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
8350: 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 -get-top-process
8360: 2d 70 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 -pid run-id (lis
8370: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
8380: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
8390: 74 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 t:get-run-ids-ma
83a0: 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 6b 65 tching-target ke
83b0: 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 ynames target re
83c0: 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 s runname testpa
83d0: 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 61 tt statepatt sta
83e0: 74 75 73 70 61 74 74 29 0a 20 20 28 72 6d 74 3a tuspatt). (rmt:
83f0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
8400: 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 t-run-ids-matchi
8410: 6e 67 2d 74 61 72 67 65 74 20 23 66 20 28 6c 69 ng-target #f (li
8420: 73 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 st keynames targ
8430: 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 74 et res runname t
8440: 65 73 74 70 61 74 74 20 73 74 61 74 65 70 61 74 estpatt statepat
8450: 74 20 73 74 61 74 75 73 70 61 74 74 29 29 29 0a t statuspatt))).
8460: 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 77 .;; NOTE: This w
8470: 69 6c 6c 20 6f 70 65 6e 20 61 6e 64 20 61 63 63 ill open and acc
8480: 65 73 73 20 41 4c 4c 20 72 75 6e 20 64 61 74 61 ess ALL run data
8490: 62 61 73 65 73 2e 20 0a 3b 3b 0a 28 64 65 66 69 bases. .;;.(defi
84a0: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ne (rmt:test-get
84b0: 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d -paths-matching-
84c0: 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d keynames-target-
84d0: 6e 65 77 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 new keynames tar
84e0: 67 65 74 20 72 65 73 20 74 65 73 74 70 61 74 74 get res testpatt
84f0: 20 73 74 61 74 65 70 61 74 74 20 73 74 61 74 75 statepatt statu
8500: 73 70 61 74 74 20 72 75 6e 6e 61 6d 65 29 0a 20 spatt runname).
8510: 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 73 20 (let ((run-ids
8520: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 64 73 (rmt:get-run-ids
8530: 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 -matching-target
8540: 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
8550: 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 res runname tes
8560: 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 tpatt statepatt
8570: 73 74 61 74 75 73 70 61 74 74 29 29 29 0a 20 20 statuspatt))).
8580: 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 (apply append
8590: 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 .. (map (lambd
85a0: 61 20 28 72 75 6e 2d 69 64 29 0a 09 09 20 20 28 a (run-id)... (
85b0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
85c0: 20 27 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 'test-get-paths
85d0: 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d -matching-keynam
85e0: 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 72 75 es-target-new ru
85f0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
8600: 64 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 d keynames targe
8610: 74 20 72 65 73 20 74 65 73 74 70 61 74 74 20 73 t res testpatt s
8620: 74 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 tatepatt statusp
8630: 61 74 74 20 72 75 6e 6e 61 6d 65 29 29 29 0a 09 att runname)))..
8640: 20 20 20 72 75 6e 2d 69 64 73 29 29 29 29 0a 0a run-ids))))..
8650: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
8660: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
8670: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
8680: 72 65 66 2d 74 65 73 74 2d 6e 61 6d 65 20 72 65 ref-test-name re
8690: 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 6b 65 f-item-path #!ke
86a0: 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 6d 61 6c y (mode '(normal
86b0: 29 29 28 69 74 65 6d 6d 61 70 73 20 23 66 29 29 ))(itemmaps #f))
86c0: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
86d0: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
86e0: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
86f0: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
8700: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
8710: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
8720: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8730: 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d -id waitons ref-
8740: 74 65 73 74 2d 6e 61 6d 65 20 72 65 66 2d 69 74 test-name ref-it
8750: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 20 69 74 65 em-path mode ite
8760: 6d 6d 61 70 73 29 29 29 0a 0a 28 64 65 66 69 6e mmaps)))..(defin
8770: 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 e (rmt:get-count
8780: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
8790: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
87a0: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
87b0: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
87c0: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
87d0: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 ired."). (rmt:s
87e0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
87f0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
8800: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ning-for-run-id
8810: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8820: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
8830: 28 72 6d 74 3a 67 65 74 2d 6e 6f 74 2d 63 6f 6d (rmt:get-not-com
8840: 70 6c 65 74 65 64 2d 63 6e 74 20 72 75 6e 2d 69 pleted-cnt run-i
8850: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
8860: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
8870: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
8880: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
8890: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
88a0: 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 2d t-not-completed-
88b0: 63 6e 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 cnt run-id (list
88c0: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 0a 3b 3b 20 run-id)))...;;
88d0: 53 74 61 74 69 73 74 69 63 61 6c 20 71 75 65 72 Statistical quer
88e0: 69 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ies..(define (rm
88f0: 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 t:get-count-test
8900: 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 s-running run-id
8910: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
8920: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
8930: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
8940: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 ired."). (rmt:s
8950: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8960: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
8970: 6e 69 6e 67 20 72 75 6e 2d 69 64 20 28 6c 69 73 ning run-id (lis
8980: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
8990: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f fine (rmt:get-co
89a0: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
89b0: 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d 65 20 72 g-for-testname r
89c0: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 29 0a un-id testname).
89d0: 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 (assert (numbe
89e0: 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 r? run-id) "FATA
89f0: 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 L: Run id requir
8a00: 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e ed."). (rmt:sen
8a10: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 d-receive 'get-c
8a20: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
8a30: 6e 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d 65 20 ng-for-testname
8a40: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8a50: 2d 69 64 20 74 65 73 74 6e 61 6d 65 29 29 29 0a -id testname))).
8a60: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
8a70: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
8a80: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
8a90: 70 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 p run-id jobgrou
8aa0: 70 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 p). (assert (nu
8ab0: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
8ac0: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
8ad0: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
8ae0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
8af0: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
8b00: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
8b10: 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 p run-id (list r
8b20: 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 29 29 un-id jobgroup))
8b30: 29 0a 0a 3b 3b 20 73 74 61 74 65 20 61 6e 64 20 )..;; state and
8b40: 73 74 61 74 75 73 20 61 72 65 20 65 78 74 72 61 status are extra
8b50: 20 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 61 6c hints not usual
8b60: 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 63 ly used in the c
8b70: 61 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 64 alculation.;;.(d
8b80: 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 73 efine (rmt:set-s
8b90: 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d tate-status-and-
8ba0: 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 roll-up-items ru
8bb0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
8bc0: 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 tem-path state s
8bd0: 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 0a 20 tatus comment).
8be0: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
8bf0: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
8c00: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
8c10: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 d."). (rmt:send
8c20: 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d 73 74 -receive 'set-st
8c30: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
8c40: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
8c50: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
8c60: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
8c70: 70 61 74 68 20 73 74 61 74 65 20 73 74 61 74 75 path state statu
8c80: 73 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 s comment)))..(d
8c90: 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 73 efine (rmt:set-s
8ca0: 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d tate-status-and-
8cb0: 72 6f 6c 6c 2d 75 70 2d 72 75 6e 20 72 75 6e 2d roll-up-run run-
8cc0: 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 29 id state status)
8cd0: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
8ce0: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
8cf0: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
8d00: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
8d10: 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d nd-receive 'set-
8d20: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
8d30: 2d 72 6f 6c 6c 2d 75 70 2d 72 75 6e 20 72 75 6e -roll-up-run run
8d40: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
8d50: 20 73 74 61 74 65 20 73 74 61 74 75 73 29 29 29 state status)))
8d60: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ...(define (rmt:
8d70: 75 70 64 61 74 65 2d 70 61 73 73 2d 66 61 69 6c update-pass-fail
8d80: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
8d90: 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 61 73 73 est-name). (ass
8da0: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
8db0: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
8dc0: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
8dd0: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
8de0: 61 6c 6c 20 27 75 70 64 61 74 65 2d 70 61 73 73 all 'update-pass
8df0: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e -fail-counts run
8e00: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 -id test-name te
8e10: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
8e20: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d e))..(define (rm
8e30: 74 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 t:top-test-set-p
8e40: 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e er-pf-counts run
8e50: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
8e60: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
8e70: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
8e80: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
8e90: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 d."). (rmt:send
8ea0: 2d 72 65 63 65 69 76 65 20 27 74 6f 70 2d 74 65 -receive 'top-te
8eb0: 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f st-set-per-pf-co
8ec0: 75 6e 74 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 unts run-id (lis
8ed0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 t run-id test-na
8ee0: 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 me)))..(define (
8ef0: 72 6d 74 3a 67 65 74 2d 72 61 77 2d 72 75 6e 2d rmt:get-raw-run-
8f00: 73 74 61 74 73 20 72 75 6e 2d 69 64 29 0a 20 20 stats run-id).
8f10: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
8f20: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
8f30: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
8f40: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
8f50: 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 61 77 receive 'get-raw
8f60: 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 -run-stats run-i
8f70: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 d (list run-id))
8f80: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
8f90: 67 65 74 2d 74 65 73 74 2d 74 69 6d 65 73 20 72 get-test-times r
8fa0: 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 29 0a 20 unname target).
8fb0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
8fc0: 76 65 20 27 67 65 74 2d 74 65 73 74 2d 74 69 6d ve 'get-test-tim
8fd0: 65 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 6e es #f (list runn
8fe0: 61 6d 65 20 74 61 72 67 65 74 20 29 29 29 20 0a ame target ))) .
8ff0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
9000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 =========.;; R
9040: 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d U N S.;;========
9050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
9090: 3b 3b 20 42 55 47 20 2d 20 4c 4f 4f 4b 20 41 54 ;; BUG - LOOK AT
90a0: 20 48 4f 57 20 54 48 49 53 20 57 4f 52 4b 53 21 HOW THIS WORKS!
90b0: 21 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 !!.;;.(define (r
90c0: 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 mt:get-run-info
90d0: 72 75 6e 2d 69 64 29 0a 20 20 28 61 73 73 65 72 run-id). (asser
90e0: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
90f0: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
9100: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
9110: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
9120: 65 20 27 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 e 'get-run-info
9130: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
9140: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
9150: 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 72 75 :get-num-runs ru
9160: 6e 70 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 npatt). (rmt:se
9170: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
9180: 6e 75 6d 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 num-runs #f (lis
9190: 74 20 72 75 6e 70 61 74 74 29 29 29 0a 0a 28 64 t runpatt)))..(d
91a0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
91b0: 75 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 uns-cnt-by-patt
91c0: 72 75 6e 70 61 74 74 20 74 61 72 67 65 74 70 61 runpatt targetpa
91d0: 74 74 20 6b 65 79 73 29 0a 20 20 28 72 6d 74 3a tt keys). (rmt:
91e0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
91f0: 74 2d 72 75 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 t-runs-cnt-by-pa
9200: 74 74 20 23 66 20 28 6c 69 73 74 20 72 75 6e 70 tt #f (list runp
9210: 61 74 74 20 20 74 61 72 67 65 74 70 61 74 74 20 att targetpatt
9220: 6b 65 79 73 29 29 29 0a 0a 3b 3b 20 55 73 65 20 keys)))..;; Use
9230: 74 68 65 20 73 70 65 63 69 61 6c 20 72 75 6e 2d the special run-
9240: 69 64 20 3d 3d 20 23 66 20 73 63 65 6e 61 72 69 id == #f scenari
9250: 6f 20 68 65 72 65 20 73 69 6e 63 65 20 74 68 65 o here since the
9260: 72 65 20 69 73 20 6e 6f 20 72 75 6e 20 79 65 74 re is no run yet
9270: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 .(define (rmt:re
9280: 67 69 73 74 65 72 2d 72 75 6e 20 6b 65 79 76 61 gister-run keyva
9290: 6c 73 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 ls runname state
92a0: 20 73 74 61 74 75 73 20 75 73 65 72 20 63 6f 6e status user con
92b0: 74 6f 75 72 29 0a 20 20 28 72 6d 74 3a 73 65 6e tour). (rmt:sen
92c0: 64 2d 72 65 63 65 69 76 65 20 27 72 65 67 69 73 d-receive 'regis
92d0: 74 65 72 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 ter-run #f (list
92e0: 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 keyvals runname
92f0: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 73 state status us
9300: 65 72 20 63 6f 6e 74 6f 75 72 29 29 29 0a 20 20 er contour))).
9310: 20 20 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a .(define (rmt:
9320: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
9330: 6d 2d 69 64 20 72 75 6e 2d 69 64 29 0a 20 20 28 m-id run-id). (
9340: 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 assert (number?
9350: 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 run-id) "FATAL:
9360: 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e Run id required.
9370: 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 "). (rmt:send-r
9380: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d eceive 'get-run-
9390: 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 23 66 20 name-from-id #f
93a0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
93b0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 .(define (rmt:de
93c0: 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 29 lete-run run-id)
93d0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
93e0: 65 69 76 65 20 27 64 65 6c 65 74 65 2d 72 75 6e eive 'delete-run
93f0: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
9400: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
9410: 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 t:update-run-sta
9420: 74 73 20 72 75 6e 2d 69 64 20 73 74 61 74 73 29 ts run-id stats)
9430: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
9440: 65 69 76 65 20 27 75 70 64 61 74 65 2d 72 75 6e eive 'update-run
9450: 2d 73 74 61 74 73 20 23 66 20 28 6c 69 73 74 20 -stats #f (list
9460: 72 75 6e 2d 69 64 20 73 74 61 74 73 29 29 29 0a run-id stats))).
9470: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 .(define (rmt:de
9480: 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 lete-old-deleted
9490: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 -test-records).
94a0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
94b0: 76 65 20 27 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 ve 'delete-old-d
94c0: 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f eleted-test-reco
94d0: 72 64 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 rds #f '()))..(d
94e0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
94f0: 75 6e 73 20 72 75 6e 70 61 74 74 20 63 6f 75 6e uns runpatt coun
9500: 74 20 6f 66 66 73 65 74 20 6b 65 79 70 61 74 74 t offset keypatt
9510: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
9520: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 73 eceive 'get-runs
9530: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 70 61 74 #f (list runpat
9540: 74 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 20 6b t count offset k
9550: 65 79 70 61 74 74 73 29 29 29 0a 0a 28 64 65 66 eypatts)))..(def
9560: 69 6e 65 20 28 72 6d 74 3a 73 69 6d 70 6c 65 2d ine (rmt:simple-
9570: 67 65 74 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 get-runs runpatt
9580: 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 20 74 61 count offset ta
9590: 72 67 65 74 20 6c 61 73 74 2d 75 70 64 61 74 65 rget last-update
95a0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
95b0: 63 65 69 76 65 20 27 73 69 6d 70 6c 65 2d 67 65 ceive 'simple-ge
95c0: 74 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 t-runs #f (list
95d0: 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 runpatt count of
95e0: 66 73 65 74 20 74 61 72 67 65 74 20 6c 61 73 74 fset target last
95f0: 2d 75 70 64 61 74 65 29 29 29 0a 0a 28 64 65 66 -update)))..(def
9600: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c ine (rmt:get-all
9610: 2d 72 75 6e 2d 69 64 73 29 0a 20 20 28 72 6d 74 -run-ids). (rmt
9620: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
9630: 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 20 23 et-all-run-ids #
9640: 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 f '()))..(define
9650: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 2d 72 (rmt:get-prev-r
9660: 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 29 0a 20 un-ids run-id).
9670: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
9680: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
9690: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
96a0: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 d."). (rmt:send
96b0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 70 72 -receive 'get-pr
96c0: 65 76 2d 72 75 6e 2d 69 64 73 20 23 66 20 28 6c ev-run-ids #f (l
96d0: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 ist run-id)))..(
96e0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 6c 6f 63 6b define (rmt:lock
96f0: 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d /unlock-run run-
9700: 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 id lock unlock u
9710: 73 65 72 29 0a 20 20 28 61 73 73 65 72 74 20 28 ser). (assert (
9720: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
9730: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
9740: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
9750: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
9760: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 lock/unlock-run
9770: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 #f (list run-id
9780: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
9790: 29 29 29 0a 0a 3b 3b 20 73 65 74 2f 67 65 74 20 )))..;; set/get
97a0: 73 74 61 74 75 73 0a 28 64 65 66 69 6e 65 20 28 status.(define (
97b0: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 rmt:get-run-stat
97c0: 75 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 61 73 us run-id). (as
97d0: 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 sert (number? ru
97e0: 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 n-id) "FATAL: Ru
97f0: 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 n id required.")
9800: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
9810: 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 eive 'get-run-st
9820: 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 75 atus #f (list ru
9830: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
9840: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 (rmt:get-run-st
9850: 61 74 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 61 ate run-id). (a
9860: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
9870: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
9880: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
9890: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
98a0: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 ceive 'get-run-s
98b0: 74 61 74 65 20 23 66 20 28 6c 69 73 74 20 72 75 tate #f (list ru
98c0: 6e 2d 69 64 29 29 29 0a 0a 0a 28 64 65 66 69 6e n-id)))...(defin
98d0: 65 20 28 72 6d 74 3a 73 65 74 2d 72 75 6e 2d 73 e (rmt:set-run-s
98e0: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 72 75 6e tatus run-id run
98f0: 2d 73 74 61 74 75 73 20 23 21 6b 65 79 20 28 6d -status #!key (m
9900: 73 67 20 23 66 29 29 0a 20 20 28 61 73 73 65 72 sg #f)). (asser
9910: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
9920: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
9930: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
9940: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
9950: 65 20 27 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 e 'set-run-statu
9960: 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 s #f (list run-i
9970: 64 20 72 75 6e 2d 73 74 61 74 75 73 20 6d 73 67 d run-status msg
9980: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
9990: 74 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 65 2d t:set-run-state-
99a0: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 73 74 status run-id st
99b0: 61 74 65 20 73 74 61 74 75 73 20 29 0a 20 20 28 ate status ). (
99c0: 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 assert (number?
99d0: 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 run-id) "FATAL:
99e0: 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e Run id required.
99f0: 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 "). (rmt:send-r
9a00: 65 63 65 69 76 65 20 27 73 65 74 2d 72 75 6e 2d eceive 'set-run-
9a10: 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 state-status #f
9a20: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 73 74 61 (list run-id sta
9a30: 74 65 20 73 74 61 74 75 73 29 29 29 0a 0a 28 64 te status)))..(d
9a40: 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 61 74 efine (rmt:updat
9a50: 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 70 e-tesdata-on-rep
9a60: 69 6c 63 61 74 65 2d 64 62 20 6f 6c 64 2d 6c 74 ilcate-db old-lt
9a70: 20 6e 65 77 2d 6c 74 29 0a 28 72 6d 74 3a 73 65 new-lt).(rmt:se
9a80: 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 nd-receive 'upda
9a90: 74 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 te-tesdata-on-re
9aa0: 70 69 6c 63 61 74 65 2d 64 62 20 23 66 20 28 6c pilcate-db #f (l
9ab0: 69 73 74 20 6f 6c 64 2d 6c 74 20 6e 65 77 2d 6c ist old-lt new-l
9ac0: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 t)))..(define (r
9ad0: 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 mt:update-run-ev
9ae0: 65 6e 74 5f 74 69 6d 65 20 72 75 6e 2d 69 64 29 ent_time run-id)
9af0: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
9b00: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
9b10: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
9b20: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
9b30: 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 nd-receive 'upda
9b40: 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d te-run-event_tim
9b50: 65 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 e #f (list run-i
9b60: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
9b70: 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 mt:get-runs-by-p
9b80: 61 74 74 20 20 6b 65 79 73 20 72 75 6e 6e 61 6d att keys runnam
9b90: 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 6f epatt targpatt o
9ba0: 66 66 73 65 74 20 6c 69 6d 69 74 20 66 69 65 6c ffset limit fiel
9bb0: 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 70 64 ds last-runs-upd
9bc0: 61 74 65 20 20 23 21 6b 65 79 20 20 28 73 6f 72 ate #!key (sor
9bd0: 74 2d 6f 72 64 65 72 20 22 61 73 63 22 29 29 20 t-order "asc"))
9be0: 3b 3b 20 66 69 65 6c 64 73 20 6f 66 20 23 66 20 ;; fields of #f
9bf0: 75 73 65 73 20 64 65 66 61 75 6c 74 0a 20 20 28 uses default. (
9c00: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
9c10: 20 27 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 'get-runs-by-pa
9c20: 74 74 20 23 66 20 28 6c 69 73 74 20 6b 65 79 73 tt #f (list keys
9c30: 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 runnamepatt tar
9c40: 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c 69 6d gpatt offset lim
9c50: 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 2d 72 it fields last-r
9c60: 75 6e 73 2d 75 70 64 61 74 65 20 73 6f 72 74 2d uns-update sort-
9c70: 6f 72 64 65 72 29 29 29 0a 0a 28 64 65 66 69 6e order)))..(defin
9c80: 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d e (rmt:find-and-
9c90: 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 mark-incomplete
9ca0: 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 run-id ovr-deadt
9cb0: 69 6d 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 ime). (assert (
9cc0: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
9cd0: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
9ce0: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 3b 3b 20 equired."). ;;
9cf0: 28 69 66 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 (if (rmt:send-re
9d00: 63 65 69 76 65 20 27 68 61 76 65 2d 69 6e 63 6f ceive 'have-inco
9d10: 6d 70 6c 65 74 65 73 3f 20 72 75 6e 2d 69 64 20 mpletes? run-id
9d20: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6f 76 72 (list run-id ovr
9d30: 2d 64 65 61 64 74 69 6d 65 29 29 0a 20 20 28 72 -deadtime)). (r
9d40: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9d50: 27 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 'mark-incomplete
9d60: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
9d70: 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 6d n-id ovr-deadtim
9d80: 65 29 29 29 20 3b 3b 20 29 0a 0a 28 64 65 66 69 e))) ;; )..(defi
9d90: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d 61 69 6e ne (rmt:get-main
9da0: 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 -run-stats run-i
9db0: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
9dc0: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
9dd0: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
9de0: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
9df0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
9e00: 74 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 61 74 73 t-main-run-stats
9e10: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
9e20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
9e30: 74 3a 67 65 74 2d 76 61 72 20 76 61 72 6e 61 6d t:get-var varnam
9e40: 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 e). (rmt:send-r
9e50: 65 63 65 69 76 65 20 27 67 65 74 2d 76 61 72 20 eceive 'get-var
9e60: 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 #f (list varname
9e70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
9e80: 74 3a 64 65 6c 2d 76 61 72 20 76 61 72 6e 61 6d t:del-var varnam
9e90: 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 e). (rmt:send-r
9ea0: 65 63 65 69 76 65 20 27 64 65 6c 2d 76 61 72 20 eceive 'del-var
9eb0: 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 #f (list varname
9ec0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
9ed0: 74 3a 73 65 74 2d 76 61 72 20 76 61 72 6e 61 6d t:set-var varnam
9ee0: 65 20 76 61 6c 75 65 29 0a 20 20 28 72 6d 74 3a e value). (rmt:
9ef0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 send-receive 'se
9f00: 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 t-var #f (list v
9f10: 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 29 29 0a arname value))).
9f20: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 69 6e .(define (rmt:in
9f30: 63 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 c-var varname).
9f40: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
9f50: 76 65 20 27 69 6e 63 2d 76 61 72 20 23 66 20 28 ve 'inc-var #f (
9f60: 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 0a list varname))).
9f70: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 .(define (rmt:de
9f80: 63 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 c-var varname).
9f90: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
9fa0: 76 65 20 27 64 65 63 2d 76 61 72 20 23 66 20 28 ve 'dec-var #f (
9fb0: 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 0a list varname))).
9fc0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 64 .(define (rmt:ad
9fd0: 64 2d 76 61 72 20 76 61 72 6e 61 6d 65 20 76 61 d-var varname va
9fe0: 6c 75 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 lue). (rmt:send
9ff0: 2d 72 65 63 65 69 76 65 20 27 61 64 64 2d 76 61 -receive 'add-va
a000: 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 r #f (list varna
a010: 6d 65 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 3d me value)))..;;=
a020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a060: 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4c 20 54 =====.;; M U L T
a070: 20 49 20 52 20 55 20 4e 20 20 20 51 20 55 20 45 I R U N Q U E
a080: 20 52 20 49 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d R I E S.;;=====
a090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0d0: 3d 0a 0a 3b 3b 20 4e 65 65 64 20 74 6f 20 6d 6f =..;; Need to mo
a0e0: 76 65 20 74 68 69 73 20 74 6f 20 6d 75 6c 74 69 ve this to multi
a0f0: 2d 72 75 6e 20 73 65 63 74 69 6f 6e 20 61 6e 64 -run section and
a100: 20 6d 61 6b 65 20 61 73 73 6f 63 69 61 74 65 64 make associated
a110: 20 63 68 61 6e 67 65 73 0a 28 64 65 66 69 6e 65 changes.(define
a120: 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d (rmt:find-and-m
a130: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 2d 61 ark-incomplete-a
a140: 6c 6c 2d 72 75 6e 73 20 23 21 6b 65 79 20 28 6f ll-runs #!key (o
a150: 76 72 2d 64 65 61 64 74 69 6d 65 20 23 66 29 29 vr-deadtime #f))
a160: 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 . (let ((run-id
a170: 73 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 s (rmt:get-all-r
a180: 75 6e 2d 69 64 73 29 29 29 0a 20 20 20 20 28 66 un-ids))). (f
a190: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
a1a0: 28 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 20 20 (run-id)..
a1b0: 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d (rmt:find-and-m
a1c0: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 ark-incomplete r
a1d0: 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 un-id ovr-deadti
a1e0: 6d 65 29 29 0a 09 20 20 20 20 20 72 75 6e 2d 69 me)).. run-i
a1f0: 64 73 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 ds)))..;; get th
a200: 65 20 70 72 65 76 69 6f 75 73 20 72 65 63 6f 72 e previous recor
a210: 64 20 66 6f 72 20 77 68 65 6e 20 74 68 69 73 20 d for when this
a220: 74 65 73 74 20 77 61 73 20 72 75 6e 20 77 68 65 test was run whe
a230: 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 re all keys matc
a240: 68 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b 3b h but runname.;;
a250: 20 72 65 74 75 72 6e 73 20 23 66 20 69 66 20 6e returns #f if n
a260: 6f 20 73 75 63 68 20 74 65 73 74 20 66 6f 75 6e o such test foun
a270: 64 2c 20 72 65 74 75 72 6e 73 20 61 20 73 69 6e d, returns a sin
a280: 67 6c 65 20 74 65 73 74 20 72 65 63 6f 72 64 20 gle test record
a290: 69 66 20 66 6f 75 6e 64 0a 3b 3b 20 0a 3b 3b 20 if found.;; .;;
a2a0: 52 75 6e 20 74 68 69 73 20 61 74 20 74 68 65 20 Run this at the
a2b0: 63 6c 69 65 6e 74 20 65 6e 64 20 73 69 6e 63 65 client end since
a2c0: 20 77 65 20 68 61 76 65 20 74 6f 20 63 6f 6e 6e we have to conn
a2d0: 65 63 74 20 74 6f 20 6d 75 6c 74 69 70 6c 65 20 ect to multiple
a2e0: 72 75 6e 2d 69 64 20 64 62 73 0a 3b 3b 0a 28 64 run-id dbs.;;.(d
a2f0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 efine (rmt:get-p
a300: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
a310: 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 -record run-id t
a320: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
a330: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 th). (let* ((ke
a340: 79 76 61 6c 73 20 28 72 6d 74 3a 67 65 74 2d 6b yvals (rmt:get-k
a350: 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e ey-val-pairs run
a360: 2d 69 64 29 29 0a 09 20 28 6b 65 79 73 20 20 20 -id)).. (keys
a370: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 (rmt:get-keys))
a380: 0a 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 .. (selstr (str
a390: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
a3a0: 20 6b 65 79 73 20 22 2c 22 29 29 0a 09 20 28 71 keys ",")).. (q
a3b0: 72 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 rystr (string-i
a3c0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
a3d0: 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e 63 (lambda (x)(conc
a3e0: 20 78 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 x "=?")) keys)
a3f0: 22 20 41 4e 44 20 22 29 29 29 0a 20 20 20 20 28 " AND "))). (
a400: 69 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c 73 29 if (not keyvals)
a410: 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 70 72 65 ..#f..(let ((pre
a420: 76 2d 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 v-run-ids (rmt:g
a430: 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 et-prev-run-ids
a440: 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 run-id))).. ;;
a450: 66 6f 72 20 65 61 63 68 20 72 75 6e 20 73 74 61 for each run sta
a460: 72 74 69 6e 67 20 77 69 74 68 20 74 68 65 20 6d rting with the m
a470: 6f 73 74 20 72 65 63 65 6e 74 20 6c 6f 6f 6b 20 ost recent look
a480: 74 6f 20 73 65 65 20 69 66 20 74 68 65 72 65 20 to see if there
a490: 69 73 20 61 20 6d 61 74 63 68 69 6e 67 20 74 65 is a matching te
a4a0: 73 74 0a 09 20 20 3b 3b 20 69 66 20 66 6f 75 6e st.. ;; if foun
a4b0: 64 20 74 68 65 6e 20 72 65 74 75 72 6e 20 74 68 d then return th
a4c0: 61 74 20 6d 61 74 63 68 69 6e 67 20 74 65 73 74 at matching test
a4d0: 20 72 65 63 6f 72 64 0a 09 20 20 28 64 65 62 75 record.. (debu
a4e0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
a4f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 lt-log-port* "se
a500: 6c 73 74 72 3a 20 22 20 73 65 6c 73 74 72 20 22 lstr: " selstr "
a510: 2c 20 71 72 79 73 74 72 3a 20 22 20 71 72 79 73 , qrystr: " qrys
a520: 74 72 20 22 2c 20 6b 65 79 76 61 6c 73 3a 20 22 tr ", keyvals: "
a530: 20 6b 65 79 76 61 6c 73 20 22 2c 20 70 72 65 76 keyvals ", prev
a540: 69 6f 75 73 20 72 75 6e 20 69 64 73 20 66 6f 75 ious run ids fou
a550: 6e 64 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d 69 nd: " prev-run-i
a560: 64 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c ds).. (if (null
a570: 3f 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 ? prev-run-ids)
a580: 23 66 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c #f.. (let l
a590: 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 70 oop ((hed (car p
a5a0: 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 0a 09 09 rev-run-ids))...
a5b0: 09 20 28 74 61 6c 20 28 63 64 72 20 70 72 65 76 . (tal (cdr prev
a5c0: 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 28 6c -run-ids)))...(l
a5d0: 65 74 20 28 28 72 65 73 75 6c 74 73 20 28 72 6d et ((results (rm
a5e0: 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
a5f0: 72 75 6e 20 68 65 64 20 28 63 6f 6e 63 20 74 65 run hed (conc te
a600: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
a610: 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 20 3b -path) '() '() ;
a620: 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 ; run-id testpat
a630: 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 t states statuse
a640: 73 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 s....... #f
a650: 20 23 66 20 23 66 20 20 20 20 20 20 20 20 20 20 #f #f
a660: 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 20 6c ;; offset l
a670: 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 68 69 64 65 imit not-in hide
a680: 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 09 09 /not-hide.......
a690: 20 20 20 20 20 20 23 66 20 23 66 20 23 66 20 23 #f #f #f #
a6a0: 66 20 27 6e 6f 72 6d 61 6c 29 29 29 20 3b 3b 20 f 'normal))) ;;
a6b0: 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 sort-by sort-ord
a6c0: 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d er qryvals last-
a6d0: 75 70 64 61 74 65 20 6d 6f 64 65 0a 09 09 20 20 update mode...
a6e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
a6f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
a700: 2a 20 22 47 6f 74 20 74 65 73 74 73 20 66 6f 72 * "Got tests for
a710: 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 run-id " run-id
a720: 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 ", test-name "
a730: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 test-name ", ite
a740: 6d 2d 70 61 74 68 20 22 20 69 74 65 6d 2d 70 61 m-path " item-pa
a750: 74 68 20 22 3a 20 22 20 72 65 73 75 6c 74 73 29 th ": " results)
a760: 0a 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e ... (if (and (n
a770: 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 0a 09 09 ull? results)...
a780: 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 . (not (null?
a790: 74 61 6c 29 29 29 0a 09 09 20 20 20 20 20 20 28 tal)))... (
a7a0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
a7b0: 64 72 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 dr tal))...
a7c0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 73 75 (if (null? resu
a7d0: 6c 74 73 29 20 23 66 0a 09 09 09 20 20 28 63 61 lts) #f.... (ca
a7e0: 72 20 72 65 73 75 6c 74 73 29 29 29 29 29 29 29 r results)))))))
a7f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
a800: 74 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 29 t:get-run-stats)
a810: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
a820: 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 eive 'get-run-st
a830: 61 74 73 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b ats #f '()))..;;
a840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a880: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 54 20 45 ======.;; S T E
a890: 20 50 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d P S.;;=========
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 3d 3d 3d 3d 3d 0a 0a 3b =============..;
a8e0: 3b 20 47 65 74 74 69 6e 67 20 73 74 65 70 73 20 ; Getting steps
a8f0: 69 73 20 6d 6f 72 65 20 63 6f 6d 70 6c 69 63 61 is more complica
a900: 74 65 64 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 67 69 ted..;;.;; If gi
a910: 76 65 6e 20 77 6f 72 6b 20 61 72 65 61 20 0a 3b ven work area .;
a920: 3b 20 20 31 2e 20 46 69 6e 64 20 74 68 65 20 74 ; 1. Find the t
a930: 65 73 74 64 61 74 2e 64 62 20 66 69 6c 65 0a 3b estdat.db file.;
a940: 3b 20 20 32 2e 20 4f 70 65 6e 20 74 68 65 20 74 ; 2. Open the t
a950: 65 73 74 64 61 74 2e 64 62 20 66 69 6c 65 20 61 estdat.db file a
a960: 6e 64 20 64 6f 20 74 68 65 20 71 75 65 72 79 0a nd do the query.
a970: 3b 3b 20 49 66 20 6e 6f 74 20 67 69 76 65 6e 20 ;; If not given
a980: 74 68 65 20 77 6f 72 6b 20 61 72 65 61 0a 3b 3b the work area.;;
a990: 20 20 31 2e 20 44 6f 20 61 20 72 65 6d 6f 74 65 1. Do a remote
a9a0: 20 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 68 65 call to get the
a9b0: 20 74 65 73 74 20 70 61 74 68 0a 3b 3b 20 20 32 test path.;; 2
a9c0: 2e 20 43 6f 6e 74 69 6e 75 65 20 61 73 20 61 62 . Continue as ab
a9d0: 6f 76 65 0a 3b 3b 20 0a 3b 3b 28 64 65 66 69 6e ove.;; .;;(defin
a9e0: 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 e (rmt:get-steps
a9f0: 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 -for-test run-id
aa00: 20 74 65 73 74 2d 69 64 29 0a 3b 3b 20 20 28 72 test-id).;; (r
aa10: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
aa20: 27 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 20 'get-steps-data
aa30: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 run-id (list tes
aa40: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
aa50: 20 28 72 6d 74 3a 74 65 73 74 73 74 65 70 2d 73 (rmt:teststep-s
aa60: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
aa70: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 73 74 d test-id testst
aa80: 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d 69 6e ep-name state-in
aa90: 20 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d 6d 65 status-in comme
aaa0: 6e 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 28 61 nt logfile). (a
aab0: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
aac0: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
aad0: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
aae0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 74 ). (let* ((stat
aaf0: 65 20 20 20 20 20 28 69 74 65 6d 73 3a 63 68 65 e (items:che
ab00: 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 ck-valid-items "
ab10: 73 74 61 74 65 22 20 73 74 61 74 65 2d 69 6e 29 state" state-in)
ab20: 29 0a 09 20 28 73 74 61 74 75 73 20 20 20 20 28 ).. (status (
ab30: 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c 69 items:check-vali
ab40: 64 2d 69 74 65 6d 73 20 22 73 74 61 74 75 73 22 d-items "status"
ab50: 20 73 74 61 74 75 73 2d 69 6e 29 29 29 0a 20 20 status-in))).
ab60: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 (if (or (not s
ab70: 74 61 74 65 29 28 6e 6f 74 20 73 74 61 74 75 73 tate)(not status
ab80: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
ab90: 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 3 *default-log-
aba0: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
abb0: 49 6e 76 61 6c 69 64 20 22 20 28 69 66 20 73 74 Invalid " (if st
abc0: 61 74 75 73 20 22 73 74 61 74 75 73 22 20 22 73 atus "status" "s
abd0: 74 61 74 65 22 29 0a 09 09 20 20 20 20 20 22 20 tate")... "
abe0: 76 61 6c 75 65 20 5c 22 22 20 28 69 66 20 73 74 value \"" (if st
abf0: 61 74 75 73 20 73 74 61 74 65 2d 69 6e 20 73 74 atus state-in st
ac00: 61 74 75 73 2d 69 6e 29 20 22 5c 22 2c 20 75 70 atus-in) "\", up
ac10: 64 61 74 65 20 79 6f 75 72 20 76 61 6c 69 64 76 date your validv
ac20: 61 6c 75 65 73 20 73 65 63 74 69 6f 6e 20 69 6e alues section in
ac30: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
ac40: 22 29 29 0a 20 20 20 20 28 72 6d 74 3a 73 65 6e ")). (rmt:sen
ac50: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 73 d-receive 'tests
ac60: 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 tep-set-status!
ac70: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
ac80: 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 -id test-id test
ac90: 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d step-name state-
aca0: 69 6e 20 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d in status-in com
acb0: 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 29 29 29 29 ment logfile))))
acc0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ...(define (rmt:
acd0: 64 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 6f 72 delete-steps-for
ace0: 2d 74 65 73 74 21 20 72 75 6e 2d 69 64 20 74 65 -test! run-id te
acf0: 73 74 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 st-id). (assert
ad00: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
ad10: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
ad20: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
ad30: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
ad40: 20 27 64 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 'delete-steps-f
ad50: 6f 72 2d 74 65 73 74 21 20 72 75 6e 2d 69 64 20 or-test! run-id
ad60: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
ad70: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
ad80: 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d (rmt:get-steps-
ad90: 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 for-test run-id
ada0: 74 65 73 74 2d 69 64 29 0a 20 20 28 61 73 73 65 test-id). (asse
adb0: 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d rt (number? run-
adc0: 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 id) "FATAL: Run
add0: 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 id required.").
ade0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
adf0: 76 65 20 27 67 65 74 2d 73 74 65 70 73 2d 66 6f ve 'get-steps-fo
ae00: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 28 6c r-test run-id (l
ae10: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
ae20: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
ae30: 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 69 6e rmt:get-steps-in
ae40: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
ae50: 74 65 73 74 2d 73 74 65 70 2d 69 64 29 0a 20 20 test-step-id).
ae60: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
ae70: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
ae80: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
ae90: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
aea0: 72 65 63 65 69 76 65 20 27 67 65 74 2d 73 74 65 receive 'get-ste
aeb0: 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 23 66 ps-info-by-id #f
aec0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
aed0: 73 74 2d 73 74 65 70 2d 69 64 29 29 29 0a 0a 3b st-step-id)))..;
aee0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
aef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af20: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 =======.;; T E
af30: 53 20 54 20 20 20 44 20 41 20 54 20 41 20 0a 3b S T D A T A .;
af40: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
af50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af80: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
af90: 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 74 2d (rmt:read-test-
afa0: 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 data run-id test
afb0: 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 -id categorypatt
afc0: 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 #!key (work-are
afd0: 61 20 23 66 29 29 20 0a 20 20 28 61 73 73 65 72 a #f)) . (asser
afe0: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
aff0: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
b000: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
b010: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
b020: 65 20 27 72 65 61 64 2d 74 65 73 74 2d 64 61 74 e 'read-test-dat
b030: 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 a run-id (list r
b040: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 un-id test-id ca
b050: 74 65 67 6f 72 79 70 61 74 74 29 29 29 0a 0a 28 tegorypatt)))..(
b060: 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 61 64 define (rmt:read
b070: 2d 74 65 73 74 2d 64 61 74 61 2d 76 61 72 70 61 -test-data-varpa
b080: 74 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 tt run-id test-i
b090: 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 20 76 d categorypatt v
b0a0: 61 72 70 61 74 74 20 23 21 6b 65 79 20 28 77 6f arpatt #!key (wo
b0b0: 72 6b 2d 61 72 65 61 20 23 66 29 29 20 0a 20 20 rk-area #f)) .
b0c0: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
b0d0: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
b0e0: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
b0f0: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
b100: 72 65 63 65 69 76 65 20 27 72 65 61 64 2d 74 65 receive 'read-te
b110: 73 74 2d 64 61 74 61 2d 76 61 72 70 61 74 74 20 st-data-varpatt
b120: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
b130: 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 65 -id test-id cate
b140: 67 6f 72 79 70 61 74 74 20 76 61 72 70 61 74 74 gorypatt varpatt
b150: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
b160: 74 3a 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d t:get-data-info-
b170: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
b180: 74 2d 64 61 74 61 2d 69 64 29 0a 20 20 28 61 73 t-data-id). (as
b190: 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 sert (number? ru
b1a0: 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 n-id) "FATAL: Ru
b1b0: 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 n id required.")
b1c0: 0a 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 . (rmt:send-re
b1d0: 63 65 69 76 65 20 27 67 65 74 2d 64 61 74 61 2d ceive 'get-data-
b1e0: 69 6e 66 6f 2d 62 79 2d 69 64 20 23 66 20 28 6c info-by-id #f (l
b1f0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
b200: 64 61 74 61 2d 69 64 29 29 29 0a 0a 28 64 65 66 data-id)))..(def
b210: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 ine (rmt:testmet
b220: 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 74 65 73 a-add-record tes
b230: 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 tname). (rmt:se
b240: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
b250: 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 meta-add-record
b260: 23 66 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d #f (list testnam
b270: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 e)))..(define (r
b280: 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d mt:testmeta-get-
b290: 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d 65 29 record testname)
b2a0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
b2b0: 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 2d 67 eive 'testmeta-g
b2c0: 65 74 2d 72 65 63 6f 72 64 20 23 66 20 28 6c 69 et-record #f (li
b2d0: 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 0a 0a st testname)))..
b2e0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
b2f0: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
b300: 6c 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 ld test-name fld
b310: 20 76 61 6c 29 0a 20 20 28 72 6d 74 3a 73 65 6e val). (rmt:sen
b320: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 6d d-receive 'testm
b330: 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 eta-update-field
b340: 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 2d 6e #f (list test-n
b350: 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 0a 0a ame fld val)))..
b360: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
b370: 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 t-data-rollup ru
b380: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 n-id test-id sta
b390: 74 75 73 29 0a 20 20 28 61 73 73 65 72 74 20 28 tus). (assert (
b3a0: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
b3b0: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
b3c0: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
b3d0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
b3e0: 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 test-data-rollup
b3f0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
b400: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 n-id test-id sta
b410: 74 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 tus)))..(define
b420: 28 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 (rmt:csv->test-d
b430: 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ata run-id test-
b440: 69 64 20 63 73 76 64 61 74 61 29 0a 20 20 28 61 id csvdata). (a
b450: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
b460: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
b470: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
b480: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
b490: 63 65 69 76 65 20 27 63 73 76 2d 3e 74 65 73 74 ceive 'csv->test
b4a0: 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 -data run-id (li
b4b0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
b4c0: 64 20 63 73 76 64 61 74 61 29 29 29 0a 0a 3b 3b d csvdata)))..;;
b4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b510: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 41 20 53 ======.;; T A S
b520: 20 4b 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d K S.;;=========
b530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
b570: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b define (rmt:task
b580: 73 2d 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 s-find-task-queu
b590: 65 2d 72 65 63 6f 72 64 73 20 74 61 72 67 65 74 e-records target
b5a0: 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 run-name test-p
b5b0: 61 74 74 20 73 74 61 74 65 2d 70 61 74 74 20 61 att state-patt a
b5c0: 63 74 69 6f 6e 2d 70 61 74 74 29 0a 20 20 28 72 ction-patt). (r
b5d0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
b5e0: 27 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 'find-task-queue
b5f0: 2d 72 65 63 6f 72 64 73 20 23 66 20 28 6c 69 73 -records #f (lis
b600: 74 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d t target run-nam
b610: 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 61 74 e test-patt stat
b620: 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 e-patt action-pa
b630: 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 tt)))..(define (
b640: 72 6d 74 3a 74 61 73 6b 73 2d 61 64 64 20 61 63 rmt:tasks-add ac
b650: 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 tion owner targe
b660: 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 t runname testpa
b670: 74 74 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d tt params). (rm
b680: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
b690: 74 61 73 6b 73 2d 61 64 64 20 23 66 20 28 6c 69 tasks-add #f (li
b6a0: 73 74 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 st action owner
b6b0: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 target runname t
b6c0: 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 29 29 estpatt params))
b6d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
b6e0: 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d tasks-set-state-
b6f0: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
b700: 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 param-key new-st
b710: 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ate). (rmt:send
b720: 2d 72 65 63 65 69 76 65 20 27 74 61 73 6b 73 2d -receive 'tasks-
b730: 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d set-state-given-
b740: 70 61 72 61 6d 2d 6b 65 79 20 23 66 20 28 6c 69 param-key #f (li
b750: 73 74 20 20 70 61 72 61 6d 2d 6b 65 79 20 6e 65 st param-key ne
b760: 77 2d 73 74 61 74 65 29 29 29 0a 0a 28 64 65 66 w-state)))..(def
b770: 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 67 ine (rmt:tasks-g
b780: 65 74 2d 6c 61 73 74 20 74 61 72 67 65 74 20 72 et-last target r
b790: 75 6e 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 unname). (rmt:s
b7a0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 61 73 end-receive 'tas
b7b0: 6b 73 2d 67 65 74 2d 6c 61 73 74 20 23 66 20 28 ks-get-last #f (
b7c0: 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 6e 6e list target runn
b7d0: 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ame)))..;;======
b7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b820: 0a 3b 3b 20 4e 20 4f 20 20 20 53 20 59 20 4e 20 .;; N O S Y N
b830: 43 20 20 20 44 20 42 20 0a 3b 3b 3d 3d 3d 3d 3d C D B .;;=====
b840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b880: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
b890: 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 76 61 72 20 no-sync-set var
b8a0: 76 61 6c 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 val). (rmt:send
b8b0: 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d 73 79 6e -receive 'no-syn
b8c0: 63 2d 73 65 74 20 23 66 20 60 28 2c 76 61 72 20 c-set #f `(,var
b8d0: 2c 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 ,val)))..(define
b8e0: 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 (rmt:no-sync-ge
b8f0: 74 2f 64 65 66 61 75 6c 74 20 76 61 72 20 64 65 t/default var de
b900: 66 61 75 6c 74 29 0a 20 20 28 72 6d 74 3a 73 65 fault). (rmt:se
b910: 6e 64 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d 73 nd-receive 'no-s
b920: 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 ync-get/default
b930: 23 66 20 60 28 2c 76 61 72 20 2c 64 65 66 61 75 #f `(,var ,defau
b940: 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 lt)))..(define (
b950: 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 rmt:no-sync-del!
b960: 20 76 61 72 29 0a 20 20 28 72 6d 74 3a 73 65 6e var). (rmt:sen
b970: 64 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d 73 79 d-receive 'no-sy
b980: 6e 63 2d 64 65 6c 21 20 23 66 20 60 28 2c 76 61 nc-del! #f `(,va
b990: 72 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 r)))..(define (r
b9a0: 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c mt:no-sync-get-l
b9b0: 6f 63 6b 20 6b 65 79 6e 61 6d 65 29 0a 20 20 28 ock keyname). (
b9c0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
b9d0: 20 27 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 'no-sync-get-lo
b9e0: 63 6b 20 23 66 20 60 28 2c 6b 65 79 6e 61 6d 65 ck #f `(,keyname
b9f0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
ba00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ba10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ba20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ba30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
ba40: 20 41 20 52 20 43 20 48 20 49 20 56 20 45 20 53 A R C H I V E S
ba50: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
ba60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ba70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ba80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ba90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
baa0: 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d ne (rmt:archive-
bab0: 67 65 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 get-allocations
bac0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
bad0: 74 68 20 64 6e 65 65 64 65 64 29 0a 20 20 28 72 th dneeded). (r
bae0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
baf0: 27 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c 'archive-get-all
bb00: 6f 63 61 74 69 6f 6e 73 20 23 66 20 28 6c 69 73 ocations #f (lis
bb10: 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 t testname itemp
bb20: 61 74 68 20 64 6e 65 65 64 65 64 29 29 29 0a 0a ath dneeded)))..
bb30: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 (define (rmt:arc
bb40: 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d 62 6c hive-register-bl
bb50: 6f 63 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 69 ock-name bdisk-i
bb60: 64 20 61 72 63 68 69 76 65 2d 70 61 74 68 29 0a d archive-path).
bb70: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
bb80: 69 76 65 20 27 61 72 63 68 69 76 65 2d 72 65 67 ive 'archive-reg
bb90: 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 ister-block-name
bba0: 20 23 66 20 28 6c 69 73 74 20 62 64 69 73 6b 2d #f (list bdisk-
bbb0: 69 64 20 61 72 63 68 69 76 65 2d 70 61 74 68 29 id archive-path)
bbc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
bbd0: 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 :archive-allocat
bbe0: 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 61 e-testsuite/area
bbf0: 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 2d -to-block block-
bc00: 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d id testsuite-nam
bc10: 65 20 61 72 65 61 6b 65 79 29 0a 20 20 28 72 6d e areakey). (rm
bc20: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
bc30: 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 65 archive-allocate
bc40: 2d 74 65 73 74 2d 74 6f 2d 62 6c 6f 63 6b 20 23 -test-to-block #
bc50: 66 20 28 6c 69 73 74 20 20 62 6c 6f 63 6b 2d 69 f (list block-i
bc60: 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 d testsuite-name
bc70: 20 61 72 65 61 6b 65 79 29 29 29 0a 0a 28 64 65 areakey)))..(de
bc80: 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 fine (rmt:archiv
bc90: 65 2d 72 65 67 69 73 74 65 72 2d 64 69 73 6b 20 e-register-disk
bca0: 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b bdisk-name bdisk
bcb0: 2d 70 61 74 68 20 64 66 29 0a 20 20 28 72 6d 74 -path df). (rmt
bcc0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 :send-receive 'a
bcd0: 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d rchive-register-
bce0: 64 69 73 6b 20 23 66 20 28 6c 69 73 74 20 62 64 disk #f (list bd
bcf0: 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 70 isk-name bdisk-p
bd00: 61 74 68 20 64 66 29 29 29 0a 0a 28 64 65 66 69 ath df)))..(defi
bd10: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 ne (rmt:test-set
bd20: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
bd30: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
bd40: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
bd50: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
bd60: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
bd70: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
bd80: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
bd90: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
bda0: 73 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 st-set-archive-b
bdb0: 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 28 lock-id run-id (
bdc0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
bdd0: 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 -id archive-bloc
bde0: 6b 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 k-id)))..(define
bdf0: 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 61 (rmt:test-get-a
be00: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 rchive-block-inf
be10: 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d o archive-block-
be20: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
be30: 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 receive 'test-ge
be40: 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d t-archive-block-
be50: 69 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 61 72 info #f (list ar
be60: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 29 chive-block-id))
be70: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 )...(define (rmt
be80: 6d 6f 64 3a 63 61 6c 63 2d 72 6f 2d 6d 6f 64 65 mod:calc-ro-mode
be90: 20 72 75 6e 72 65 6d 6f 74 65 20 2a 74 6f 70 70 runremote *topp
bea0: 61 74 68 2a 29 0a 20 20 28 69 66 20 28 61 6e 64 ath*). (if (and
beb0: 20 72 75 6e 72 65 6d 6f 74 65 0a 09 20 20 20 28 runremote.. (
bec0: 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 2d 63 remote-ro-mode-c
bed0: 68 65 63 6b 65 64 20 72 75 6e 72 65 6d 6f 74 65 hecked runremote
bee0: 29 29 0a 20 20 20 20 20 20 28 72 65 6d 6f 74 65 )). (remote
bef0: 2d 72 6f 2d 6d 6f 64 65 20 72 75 6e 72 65 6d 6f -ro-mode runremo
bf00: 74 65 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 te). (let*
bf10: 28 28 6d 74 63 66 67 66 69 6c 65 20 20 28 63 6f ((mtcfgfile (co
bf20: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 6d nc *toppath* "/m
bf30: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 egatest.config")
bf40: 29 0a 09 20 20 20 20 20 28 72 6f 2d 6d 6f 64 65 ).. (ro-mode
bf50: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 (not (file-writ
bf60: 65 2d 61 63 63 65 73 73 3f 20 6d 74 63 66 67 66 e-access? mtcfgf
bf70: 69 6c 65 29 29 29 29 20 3b 3b 20 54 4f 44 4f 3a ile)))) ;; TODO:
bf80: 20 75 73 65 20 64 62 73 74 72 75 63 74 20 6f 72 use dbstruct or
bf90: 20 72 75 6e 72 65 6d 6f 74 65 20 74 6f 20 66 69 runremote to fi
bfa0: 67 75 72 65 20 74 68 69 73 20 6f 75 74 20 69 6e gure this out in
bfb0: 20 66 75 74 75 72 65 0a 09 28 69 66 20 72 75 6e future..(if run
bfc0: 72 65 6d 6f 74 65 0a 09 20 20 20 20 28 62 65 67 remote.. (beg
bfd0: 69 6e 0a 09 20 20 20 20 20 20 28 72 65 6d 6f 74 in.. (remot
bfe0: 65 2d 72 6f 2d 6d 6f 64 65 2d 73 65 74 21 20 72 e-ro-mode-set! r
bff0: 75 6e 72 65 6d 6f 74 65 20 72 6f 2d 6d 6f 64 65 unremote ro-mode
c000: 29 0a 09 20 20 20 20 20 20 28 72 65 6d 6f 74 65 ).. (remote
c010: 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b 65 64 -ro-mode-checked
c020: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
c030: 23 74 29 0a 09 20 20 20 20 20 20 72 6f 2d 6d 6f #t).. ro-mo
c040: 64 65 29 0a 09 20 20 20 20 72 6f 2d 6d 6f 64 65 de).. ro-mode
c050: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 65 ))))..(define (e
c060: 78 74 72 61 73 2d 72 65 61 64 6f 6e 6c 79 2d 6d xtras-readonly-m
c070: 6f 64 65 20 72 6d 74 2d 6d 75 74 65 78 20 6c 6f ode rmt-mutex lo
c080: 67 2d 70 6f 72 74 20 63 6d 64 20 70 61 72 61 6d g-port cmd param
c090: 73 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f s). (mutex-unlo
c0a0: 63 6b 21 20 72 6d 74 2d 6d 75 74 65 78 29 0a 20 ck! rmt-mutex).
c0b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
c0c0: 66 6f 20 31 32 20 6c 6f 67 2d 70 6f 72 74 20 22 fo 12 log-port "
c0d0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
c0e0: 2c 20 63 61 73 65 20 33 22 29 0a 20 20 28 64 65 , case 3"). (de
c0f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 6c 6f 67 2d bug:print 0 log-
c100: 70 6f 72 74 20 22 57 41 52 4e 49 4e 47 3a 20 77 port "WARNING: w
c110: 72 69 74 65 20 74 72 61 6e 73 61 63 74 69 6f 6e rite transaction
c120: 20 72 65 71 75 65 73 74 65 64 20 6f 6e 20 61 20 requested on a
c130: 72 65 61 64 6f 6e 6c 79 20 61 72 65 61 2e 20 20 readonly area.
c140: 63 6d 64 3d 22 63 6d 64 22 20 70 61 72 61 6d 73 cmd="cmd" params
c150: 3d 22 70 61 72 61 6d 73 29 0a 20 20 23 66 29 0a ="params). #f).
c160: 0a 28 64 65 66 69 6e 65 20 28 65 78 74 72 61 73 .(define (extras
c170: 2d 74 72 61 6e 73 70 6f 72 74 2d 66 61 69 6c 65 -transport-faile
c180: 64 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 d *default-log-p
c190: 6f 72 74 2a 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ort* *rmt-mutex*
c1a0: 20 61 74 74 65 6d 70 74 6e 75 6d 20 72 75 6e 72 attemptnum runr
c1b0: 65 6d 6f 74 65 20 63 6d 64 20 72 69 64 20 70 61 emote cmd rid pa
c1c0: 72 61 6d 73 29 0a 20 20 28 64 65 62 75 67 3a 70 rams). (debug:p
c1d0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
c1e0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
c1f0: 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f NG: communicatio
c200: 6e 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 n failed. Trying
c210: 20 61 67 61 69 6e 2c 20 74 72 79 20 6e 75 6d 3a again, try num:
c220: 20 22 20 61 74 74 65 6d 70 74 6e 75 6d 29 0a 20 " attemptnum).
c230: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 (mutex-lock! *r
c240: 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 72 65 mt-mutex*). (re
c250: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 mote-conndat-set
c260: 21 20 20 20 20 72 75 6e 72 65 6d 6f 74 65 20 23 ! runremote #
c270: 66 29 0a 20 20 28 68 74 74 70 2d 74 72 61 6e 73 f). (http-trans
c280: 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 port:close-conne
c290: 63 74 69 6f 6e 73 20 61 72 65 61 2d 64 61 74 3a ctions area-dat:
c2a0: 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 28 72 runremote). (r
c2b0: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
c2c0: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
c2d0: 23 66 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c #f). (mutex-unl
c2e0: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
c2f0: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
c300: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
c310: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 t-log-port* "rmt
c320: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 :send-receive, c
c330: 61 73 65 20 20 39 2e 31 22 29 0a 20 20 28 72 6d ase 9.1"). (rm
c340: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 t:send-receive c
c350: 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 md rid params at
c360: 74 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 temptnum: (+ att
c370: 65 6d 70 74 6e 75 6d 20 31 29 29 29 0a 20 20 0a emptnum 1))). .
c380: 28 64 65 66 69 6e 65 20 28 65 78 74 72 61 73 2d (define (extras-
c390: 74 72 61 6e 73 70 6f 72 74 2d 73 75 63 63 65 64 transport-succed
c3a0: 65 64 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d ed *default-log-
c3b0: 70 6f 72 74 2a 20 2a 72 6d 74 2d 6d 75 74 65 78 port* *rmt-mutex
c3c0: 2a 20 61 74 74 65 6d 70 74 6e 75 6d 20 72 75 6e * attemptnum run
c3d0: 72 65 6d 6f 74 65 20 72 65 73 20 70 61 72 61 6d remote res param
c3e0: 73 20 72 69 64 20 63 6d 64 29 0a 20 20 28 69 66 s rid cmd). (if
c3f0: 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 72 (and (vector? r
c400: 65 73 29 0a 09 20 20 20 28 65 71 3f 20 28 76 65 es).. (eq? (ve
c410: 63 74 6f 72 2d 6c 65 6e 67 74 68 20 72 65 73 29 ctor-length res)
c420: 20 32 29 0a 09 20 20 20 28 65 71 3f 20 28 76 65 2).. (eq? (ve
c430: 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 ctor-ref res 1)
c440: 27 6f 76 65 72 6c 6f 61 64 65 64 29 29 20 3b 3b 'overloaded)) ;;
c450: 20 73 69 6e 63 65 20 77 65 20 61 72 65 0a 09 09 since we are...
c460: 09 09 09 09 20 3b 3b 20 6c 6f 6f 6b 69 6e 67 20 .... ;; looking
c470: 61 74 20 74 68 65 0a 09 09 09 09 09 09 20 3b 3b at the....... ;;
c480: 20 64 61 74 61 20 74 6f 20 63 61 72 72 79 20 74 data to carry t
c490: 68 65 0a 09 09 09 09 09 09 20 3b 3b 20 65 72 72 he....... ;; err
c4a0: 6f 72 20 77 65 27 6c 6c 20 75 73 65 20 61 0a 09 or we'll use a..
c4b0: 09 09 09 09 09 20 3b 3b 20 66 61 69 72 6c 79 20 ..... ;; fairly
c4c0: 6f 62 74 75 73 65 0a 09 09 09 09 09 09 20 3b 3b obtuse....... ;;
c4d0: 20 63 6f 6d 62 6f 20 74 6f 20 6d 69 6e 69 6d 69 combo to minimi
c4e0: 73 65 0a 09 09 09 09 09 09 20 3b 3b 20 74 68 65 se....... ;; the
c4f0: 20 63 68 61 6e 63 65 73 20 6f 66 0a 09 09 09 09 chances of.....
c500: 09 09 20 3b 3b 20 73 6f 6d 65 20 73 6f 72 74 20 .. ;; some sort
c510: 6f 66 0a 09 09 09 09 09 09 20 3b 3b 20 63 6f 6c of....... ;; col
c520: 6c 69 73 69 6f 6e 2e 20 20 74 68 69 73 0a 09 09 lision. this...
c530: 09 09 09 09 20 3b 3b 20 69 73 20 74 68 65 20 63 .... ;; is the c
c540: 61 73 65 20 77 68 65 72 65 0a 09 09 09 09 09 09 ase where.......
c550: 20 3b 3b 20 74 68 65 20 72 65 74 75 72 6e 65 64 ;; the returned
c560: 20 64 61 74 61 0a 09 09 09 09 09 09 20 3b 3b 20 data....... ;;
c570: 69 73 20 62 61 64 20 6f 72 20 74 68 65 0a 09 09 is bad or the...
c580: 09 09 09 09 20 3b 3b 20 73 65 72 76 65 72 20 69 .... ;; server i
c590: 73 0a 09 09 09 09 09 09 20 3b 3b 20 6f 76 65 72 s....... ;; over
c5a0: 6c 6f 61 64 65 64 20 61 6e 64 20 77 65 0a 09 09 loaded and we...
c5b0: 09 09 09 09 20 3b 3b 20 77 61 6e 74 20 74 6f 20 .... ;; want to
c5c0: 65 61 73 65 20 6f 66 66 0a 09 09 09 09 09 09 20 ease off.......
c5d0: 3b 3b 20 74 68 65 20 71 75 65 72 69 65 73 0a 20 ;; the queries.
c5e0: 20 20 20 20 20 28 6c 65 74 20 28 28 77 61 69 74 (let ((wait
c5f0: 2d 64 65 6c 61 79 20 28 2b 20 61 74 74 65 6d 70 -delay (+ attemp
c600: 74 6e 75 6d 20 28 2a 20 61 74 74 65 6d 70 74 6e tnum (* attemptn
c610: 75 6d 20 31 30 29 29 29 29 0a 09 28 64 65 62 75 um 10))))..(debu
c620: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
c630: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
c640: 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 20 69 73 RNING: server is
c650: 20 6f 76 65 72 6c 6f 61 64 65 64 2e 20 44 65 6c overloaded. Del
c660: 61 79 69 6e 67 20 22 20 77 61 69 74 2d 64 65 6c aying " wait-del
c670: 61 79 20 22 20 73 65 63 6f 6e 64 73 20 61 6e 64 ay " seconds and
c680: 20 74 72 79 69 6e 67 20 63 61 6c 6c 20 61 67 61 trying call aga
c690: 69 6e 2e 22 29 0a 09 28 6d 75 74 65 78 2d 6c 6f in.")..(mutex-lo
c6a0: 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 ck! *rmt-mutex*)
c6b0: 0a 09 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 ..(http-transpor
c6c0: 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 t:close-connecti
c6d0: 6f 6e 73 20 61 72 65 61 2d 64 61 74 3a 20 72 75 ons area-dat: ru
c6e0: 6e 72 65 6d 6f 74 65 29 0a 09 28 73 65 74 21 20 nremote)..(set!
c6f0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 20 *runremote* #f)
c700: 3b 3b 20 66 6f 72 63 65 20 73 74 61 72 74 69 6e ;; force startin
c710: 67 20 6f 76 65 72 0a 09 28 6d 75 74 65 78 2d 75 g over..(mutex-u
c720: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
c730: 78 2a 29 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 x*)..(thread-sle
c740: 65 70 21 20 77 61 69 74 2d 64 65 6c 61 79 29 0a ep! wait-delay).
c750: 09 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 .(rmt:send-recei
c760: 76 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d ve cmd rid param
c770: 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 28 2b s attemptnum: (+
c780: 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 29 attemptnum 1)))
c790: 0a 20 20 20 20 20 20 72 65 73 29 29 20 3b 3b 20 . res)) ;;
c7a0: 41 6c 6c 20 67 6f 6f 64 2c 20 72 65 74 75 72 6e All good, return
c7b0: 20 72 65 73 0a 0a 23 3b 28 73 65 74 2d 66 75 6e res..#;(set-fun
c7c0: 63 74 69 6f 6e 73 20 72 6d 74 3a 73 65 6e 64 2d ctions rmt:send-
c7d0: 72 65 63 65 69 76 65 20 20 20 20 20 20 20 20 20 receive
c7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
c7f0: 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d mote-server-url-
c800: 73 65 74 21 0a 09 20 20 20 20 20 20 20 68 74 74 set!.. htt
c810: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 p-transport:clos
c820: 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 09 20 20 e-connections.
c830: 20 20 20 20 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 remote-connd
c840: 61 74 2d 73 65 74 21 0a 09 20 20 20 20 20 20 20 at-set!..
c850: 64 65 62 75 67 3a 70 72 69 6e 74 20 20 20 20 20 debug:print
c860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c870: 20 20 20 20 20 20 20 64 65 62 75 67 3a 70 72 69 debug:pri
c880: 6e 74 2d 69 6e 66 6f 0a 09 20 20 20 20 20 20 20 nt-info..
c890: 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 20 20 remote-ro-mode
c8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8b0: 20 20 20 20 20 20 20 72 65 6d 6f 74 65 2d 72 6f remote-ro
c8c0: 2d 6d 6f 64 65 2d 73 65 74 21 0a 09 20 20 20 20 -mode-set!..
c8d0: 20 20 20 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 remote-ro-mod
c8e0: 65 2d 63 68 65 63 6b 65 64 2d 73 65 74 21 20 20 e-checked-set!
c8f0: 20 20 20 20 20 20 20 20 20 20 72 65 6d 6f 74 65 remote
c900: 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b 65 64 -ro-mode-checked
c910: 29 0a ).