Artifact
f6bea4fdfd342da3e33a84718a77f5e8bb5773ca:
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 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 6a 73 6f 6e 20 66 6f 72 6d 61 74 29 20 3b 3b json format) ;;
01f0: 20 52 41 44 54 20 3d 3e 20 70 75 72 70 6f 73 65 RADT => purpose
0200: 20 6f 66 20 6a 73 6f 6e 20 66 6f 72 6d 61 74 3f of json format?
0210: 3f 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 ?..(declare (uni
0220: 74 20 72 6d 74 29 29 0a 28 64 65 63 6c 61 72 65 t rmt)).(declare
0230: 20 28 75 73 65 73 20 61 70 69 29 29 0a 28 64 65 (uses api)).(de
0240: 63 6c 61 72 65 20 28 75 73 65 73 20 74 64 62 29 clare (uses tdb)
0250: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0260: 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 http-transport)
0270: 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 ).;;(declare (us
0280: 65 73 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 es nmsg-transpor
0290: 74 29 29 0a 3b 3b 0a 3b 3b 20 54 48 45 53 45 20 t)).;;.;; THESE
02a0: 41 52 45 20 41 4c 4c 20 43 41 4c 4c 45 44 20 4f ARE ALL CALLED O
02b0: 4e 20 54 48 45 20 43 4c 49 45 4e 54 20 53 49 44 N THE CLIENT SID
02c0: 45 21 21 21 0a 3b 3b 0a 0a 3b 3b 20 3b 3b 20 46 E!!!.;;..;; ;; F
02d0: 6f 72 20 64 65 62 75 67 67 69 6e 67 20 61 64 64 or debugging add
02e0: 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 74 the following t
02f0: 6f 20 7e 2f 2e 6d 65 67 61 74 65 73 74 72 63 0a o ~/.megatestrc.
0300: 3b 3b 0a 3b 3b 20 28 72 65 71 75 69 72 65 2d 6c ;;.;; (require-l
0310: 69 62 72 61 72 79 20 74 72 61 63 65 29 0a 3b 3b ibrary trace).;;
0320: 20 28 69 6d 70 6f 72 74 20 74 72 61 63 65 29 0a (import trace).
0330: 3b 3b 20 28 74 72 61 63 65 0a 3b 3b 20 72 6d 74 ;; (trace.;; rmt
0340: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 0a 3b 3b :send-receive.;;
0350: 20 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 api:execute-req
0360: 75 65 73 74 73 0a 3b 3b 20 29 0a 0a 3b 3b 20 67 uests.;; )..;; g
0370: 65 6e 65 72 61 74 65 20 65 6e 74 72 69 65 73 20 enerate entries
0380: 66 6f 72 20 7e 2f 2e 6d 65 67 61 74 65 73 74 72 for ~/.megatestr
0390: 63 20 77 69 74 68 20 74 68 65 20 66 6f 6c 6c 6f c with the follo
03a0: 77 69 6e 67 0a 3b 3b 0a 3b 3b 20 20 67 72 65 70 wing.;;.;; grep
03b0: 20 64 65 66 69 6e 65 20 2e 2e 2f 72 6d 74 2e 73 define ../rmt.s
03c0: 63 6d 20 7c 20 67 72 65 70 20 72 6d 74 3a 20 7c cm | grep rmt: |
03d0: 70 65 72 6c 20 2d 70 69 20 2d 65 20 27 73 2f 5c perl -pi -e 's/\
03e0: 28 64 65 66 69 6e 65 5c 73 2b 5c 28 28 5c 53 2b (define\s+\((\S+
03f0: 29 5c 57 2e 2a 24 2f 5c 31 2f 27 7c 73 6f 72 74 )\W.*$/\1/'|sort
0400: 20 2d 75 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d -u...;;========
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
0450: 3b 20 20 53 20 55 20 50 20 50 20 4f 20 52 20 54 ; S U P P O R T
0460: 20 20 20 46 20 55 20 4e 20 43 20 54 20 49 20 4f F U N C T I O
0470: 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d N S.;;=========
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
04c0: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 77 ;.(define (rmt:w
04d0: 72 69 74 65 2d 66 72 65 71 75 65 6e 63 79 2d 6f rite-frequency-o
04e0: 76 65 72 2d 6c 69 6d 69 74 3f 20 63 6d 64 20 72 ver-limit? cmd r
04f0: 75 6e 2d 69 64 29 0a 20 20 28 61 6e 64 20 28 6e un-id). (and (n
0500: 6f 74 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 ot (member cmd a
0510: 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 pi:read-only-que
0520: 72 69 65 73 29 29 0a 20 20 20 20 20 20 20 28 6c ries)). (l
0530: 65 74 2a 20 28 28 74 6d 70 72 65 63 20 28 68 61 et* ((tmprec (ha
0540: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0550: 61 75 6c 74 20 2a 77 72 69 74 65 2d 66 72 65 71 ault *write-freq
0560: 75 65 6e 63 79 2a 20 72 75 6e 2d 69 64 20 23 66 uency* run-id #f
0570: 29 29 0a 09 20 20 20 20 20 20 28 72 65 63 6f 72 )).. (recor
0580: 64 20 28 69 66 20 74 6d 70 72 65 63 20 74 6d 70 d (if tmprec tmp
0590: 72 65 63 20 0a 09 09 09 20 20 28 6c 65 74 20 28 rec .... (let (
05a0: 28 76 20 28 76 65 63 74 6f 72 20 28 63 75 72 72 (v (vector (curr
05b0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 30 29 29 ent-seconds) 0))
05c0: 29 0a 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 ).... (hash-t
05d0: 61 62 6c 65 2d 73 65 74 21 20 2a 77 72 69 74 65 able-set! *write
05e0: 2d 66 72 65 71 75 65 6e 63 79 2a 20 72 75 6e 2d -frequency* run-
05f0: 69 64 20 76 29 0a 09 09 09 20 20 20 20 76 29 29 id v).... v))
0600: 29 0a 09 20 20 20 20 20 20 28 63 6f 75 6e 74 20 ).. (count
0610: 20 28 2b 20 31 20 28 76 65 63 74 6f 72 2d 72 65 (+ 1 (vector-re
0620: 66 20 72 65 63 6f 72 64 20 31 29 29 29 0a 09 20 f record 1)))..
0630: 20 20 20 20 20 28 73 74 61 72 74 20 20 28 76 65 (start (ve
0640: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
0650: 30 29 29 0a 09 20 20 20 20 20 20 28 71 75 65 72 0)).. (quer
0660: 69 65 73 2d 70 65 72 2d 73 65 63 6f 6e 64 20 28 ies-per-second (
0670: 2f 20 28 2a 20 63 6f 75 6e 74 20 31 2e 30 29 0a / (* count 1.0).
0680: 09 09 09 09 20 20 20 20 20 28 6d 61 78 20 28 2d .... (max (-
0690: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
06a0: 73 29 20 73 74 61 72 74 29 20 31 29 29 29 29 0a s) start) 1)))).
06b0: 09 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 . (vector-set! r
06c0: 65 63 6f 72 64 20 31 20 63 6f 75 6e 74 29 0a 09 ecord 1 count)..
06d0: 20 28 69 66 20 28 61 6e 64 20 28 3e 20 63 6f 75 (if (and (> cou
06e0: 6e 74 20 31 30 29 0a 09 09 20 20 28 3e 20 71 75 nt 10)... (> qu
06f0: 65 72 69 65 73 2d 70 65 72 2d 73 65 63 6f 6e 64 eries-per-second
0700: 20 31 30 29 29 0a 09 20 20 20 20 20 28 62 65 67 10)).. (beg
0710: 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 in.. (debu
0720: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
0730: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0740: 2a 20 22 64 62 20 77 72 69 74 65 20 72 61 74 65 * "db write rate
0750: 20 74 6f 6f 20 68 69 67 68 2c 20 73 74 61 72 74 too high, start
0760: 69 6e 67 20 61 20 73 65 72 76 65 72 2c 20 63 6f ing a server, co
0770: 75 6e 74 3d 22 20 63 6f 75 6e 74 20 22 20 73 74 unt=" count " st
0780: 61 72 74 3d 22 20 73 74 61 72 74 20 22 20 72 75 art=" start " ru
0790: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 20 n-id=" run-id "
07a0: 71 75 65 72 69 65 73 2d 70 65 72 2d 73 65 63 6f queries-per-seco
07b0: 6e 64 3d 22 20 71 75 65 72 69 65 73 2d 70 65 72 nd=" queries-per
07c0: 2d 73 65 63 6f 6e 64 29 0a 09 20 20 20 20 20 20 -second)..
07d0: 20 23 74 29 0a 09 20 20 20 20 20 23 66 29 29 29 #t).. #f)))
07e0: 29 0a 0a 3b 3b 20 69 66 20 61 20 73 65 72 76 65 )..;; if a serve
07f0: 72 20 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e r is either runn
0800: 69 6e 67 20 6f 72 20 69 6e 20 74 68 65 20 70 72 ing or in the pr
0810: 6f 63 65 73 73 20 6f 66 20 73 74 61 72 74 69 6e ocess of startin
0820: 67 20 63 61 6c 6c 20 63 6c 69 65 6e 74 3a 73 65 g call client:se
0830: 74 75 70 0a 3b 3b 20 65 6c 73 65 20 72 65 74 75 tup.;; else retu
0840: 72 6e 20 23 66 20 74 6f 20 6c 65 74 20 74 68 65 rn #f to let the
0850: 20 63 61 6c 6c 69 6e 67 20 70 72 6f 63 20 6b 6e calling proc kn
0860: 6f 77 20 74 68 61 74 20 74 68 65 72 65 20 69 73 ow that there is
0870: 20 6e 6f 20 73 65 72 76 65 72 20 61 76 61 69 6c no server avail
0880: 61 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 able.;;.(define
0890: 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 (rmt:get-connect
08a0: 69 6f 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 ion-info run-id)
08b0: 0a 20 20 28 6c 65 74 20 28 28 63 69 6e 66 6f 20 . (let ((cinfo
08c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
08d0: 64 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f default *runremo
08e0: 74 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 te* run-id #f)))
08f0: 0a 20 20 20 20 28 69 66 20 63 69 6e 66 6f 0a 09 . (if cinfo..
0900: 63 69 6e 66 6f 0a 09 3b 3b 20 4e 42 2f 2f 20 63 cinfo..;; NB// c
0910: 61 6e 20 63 61 63 68 65 20 74 68 65 20 61 6e 73 an cache the ans
0920: 77 65 72 20 66 6f 72 20 73 65 72 76 65 72 20 72 wer for server r
0930: 75 6e 6e 69 6e 67 20 66 6f 72 20 31 30 20 73 65 unning for 10 se
0940: 63 6f 6e 64 73 20 2e 2e 2e 0a 09 3b 3b 20 20 3b conds .....;; ;
0950: 3b 20 28 61 6e 64 20 28 6e 6f 74 20 28 72 6d 74 ; (and (not (rmt
0960: 3a 77 72 69 74 65 2d 66 72 65 71 75 65 6e 63 79 :write-frequency
0970: 2d 6f 76 65 72 2d 6c 69 6d 69 74 3f 20 63 6d 64 -over-limit? cmd
0980: 20 72 75 6e 2d 69 64 29 29 0a 09 28 69 66 20 28 run-id))..(if (
0990: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 72 75 6e tasks:server-run
09a0: 6e 69 6e 67 2d 6f 72 2d 73 74 61 72 74 69 6e 67 ning-or-starting
09b0: 3f 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 ? (db:delay-if-b
09c0: 75 73 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d usy (tasks:open-
09d0: 64 62 29 29 20 72 75 6e 2d 69 64 29 0a 09 20 20 db)) run-id)..
09e0: 20 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 (client:setup
09f0: 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 23 66 29 run-id).. #f)
0a00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 65 )))..(define *se
0a10: 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 65 78 nd-receive-mutex
0a20: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 * (make-mutex))
0a30: 3b 3b 20 73 68 6f 75 6c 64 20 68 61 76 65 20 73 ;; should have s
0a40: 65 70 61 72 61 74 65 20 6d 75 74 65 78 20 70 65 eparate mutex pe
0a50: 72 20 72 75 6e 2d 69 64 0a 0a 3b 3b 20 52 41 20 r run-id..;; RA
0a60: 3d 3e 20 65 2e 67 2e 20 75 73 61 67 65 20 28 72 => e.g. usage (r
0a70: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
0a80: 27 67 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 'get-var #f (lis
0a90: 74 20 76 61 72 6e 61 6d 65 29 29 0a 3b 3b 0a 28 t varname)).;;.(
0aa0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e 64 define (rmt:send
0ab0: 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 -receive cmd rid
0ac0: 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 61 params #!key (a
0ad0: 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 20 3b 3b ttemptnum 1)) ;;
0ae0: 20 73 74 61 72 74 20 61 74 74 65 6d 70 74 6e 75 start attemptnu
0af0: 6d 20 61 74 20 31 20 73 6f 20 74 68 65 20 6d 6f m at 1 so the mo
0b00: 64 75 6c 6f 20 62 65 6c 6f 77 20 77 6f 72 6b 73 dulo below works
0b10: 20 61 73 20 65 78 70 65 63 74 65 64 0a 20 20 3b as expected. ;
0b20: 3b 20 63 6c 65 61 6e 20 6f 75 74 20 6f 6c 64 20 ; clean out old
0b30: 63 6f 6e 6e 65 63 74 69 6f 6e 73 0a 20 20 3b 3b connections. ;;
0b40: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
0b50: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
0b60: 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 65 78 ex*). (let ((ex
0b70: 70 69 72 65 2d 74 69 6d 65 20 28 2d 20 28 63 75 pire-time (- (cu
0b80: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
0b90: 73 65 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f server:get-timeo
0ba0: 75 74 29 20 31 30 29 29 29 20 3b 3b 20 64 6f 6e ut) 10))) ;; don
0bb0: 27 74 20 66 6f 72 67 65 74 20 74 68 65 20 31 30 't forget the 10
0bc0: 20 73 65 63 6f 6e 64 20 6d 61 72 67 69 6e 0a 20 second margin.
0bd0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
0be0: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d (lambda (run-
0bf0: 69 64 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 id). (let
0c00: 28 28 63 6f 6e 6e 65 63 74 69 6f 6e 20 28 68 61 ((connection (ha
0c10: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
0c20: 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a ault *runremote*
0c30: 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 20 20 run-id #f))).
0c40: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
0c50: 28 76 65 63 74 6f 72 3f 20 63 6f 6e 6e 65 63 74 (vector? connect
0c60: 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 09 20 20 ion). .
0c70: 28 3c 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (< (http-transpo
0c80: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
0c90: 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 63 6f t-last-access co
0ca0: 6e 6e 65 63 74 69 6f 6e 29 20 65 78 70 69 72 65 nnection) expire
0cb0: 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -time)).
0cc0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
0cd0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
0ce0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
0cf0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0d00: 2a 20 22 44 69 73 63 61 72 64 69 6e 67 20 63 6f * "Discarding co
0d10: 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 76 nnection to serv
0d20: 65 72 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 er for run-id "
0d30: 72 75 6e 2d 69 64 20 22 2c 20 74 6f 6f 20 6c 6f run-id ", too lo
0d40: 6e 67 20 62 65 74 77 65 65 6e 20 61 63 63 65 73 ng between acces
0d50: 73 65 73 22 29 0a 20 20 20 20 20 20 20 20 20 20 ses").
0d60: 20 20 20 20 20 3b 3b 20 62 62 2d 20 64 69 73 61 ;; bb- disa
0d70: 62 6c 69 6e 67 20 6e 61 6e 6f 6d 73 67 0a 20 20 bling nanomsg.
0d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0d90: 53 48 4f 55 4c 44 20 43 4c 4f 53 45 20 54 48 45 SHOULD CLOSE THE
0da0: 20 43 4f 4e 4e 45 43 54 49 4f 4e 20 48 45 52 45 CONNECTION HERE
0db0: 20 0a 09 20 20 20 20 20 20 20 3b 3b 20 28 63 61 .. ;; (ca
0dc0: 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 se *transport-ty
0dd0: 70 65 2a 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 pe*.. ;;
0de0: 20 28 28 6e 6d 73 67 29 28 6e 6e 2d 63 6c 6f 73 ((nmsg)(nn-clos
0df0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
0e00: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
0e10: 2d 73 6f 63 6b 65 74 20 0a 09 20 20 20 20 20 20 -socket ..
0e20: 20 3b 3b 20 20 09 09 20 20 20 28 68 61 73 68 2d ;; .. (hash-
0e30: 74 61 62 6c 65 2d 72 65 66 20 2a 72 75 6e 72 65 table-ref *runre
0e40: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 29 29 29 29 mote* run-id))))
0e50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0e60: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c (hash-table-del
0e70: 65 74 65 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a ete! *runremote*
0e80: 20 72 75 6e 2d 69 64 29 29 29 29 29 0a 20 20 20 run-id))))).
0e90: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
0ea0: 79 73 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 ys *runremote*))
0eb0: 29 0a 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 6e ). ;; (mutex-un
0ec0: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
0ed0: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 3b sync-mutex*). ;
0ee0: 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a ; (mutex-lock! *
0ef0: 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 send-receive-mut
0f00: 65 78 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 ex*). (let* ((r
0f10: 75 6e 2d 69 64 20 20 20 20 20 20 20 20 20 20 28 un-id (
0f20: 69 66 20 72 69 64 20 72 69 64 20 30 29 29 0a 09 if rid rid 0))..
0f30: 20 28 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 (connection-inf
0f40: 6f 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 o (rmt:get-conne
0f50: 63 74 69 6f 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 ction-info run-i
0f60: 64 29 29 29 0a 20 20 20 20 3b 3b 20 74 68 65 20 d))). ;; the
0f70: 6e 6d 73 67 20 6d 65 74 68 6f 64 20 64 6f 65 73 nmsg method does
0f80: 20 74 68 65 20 65 6e 63 6f 64 69 6e 67 20 75 6e the encoding un
0f90: 64 65 72 20 74 68 65 20 68 6f 6f 64 20 28 74 68 der the hood (th
0fa0: 65 20 68 74 74 70 20 6d 65 74 68 6f 64 20 73 68 e http method sh
0fb0: 6f 75 6c 64 20 62 65 20 63 68 61 6e 67 65 64 20 ould be changed
0fc0: 74 6f 20 64 6f 20 74 68 69 73 20 61 6c 73 6f 29 to do this also)
0fd0: 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e 65 63 74 . (if connect
0fe0: 69 6f 6e 2d 69 6e 66 6f 0a 09 3b 3b 20 75 73 65 ion-info..;; use
0ff0: 20 74 68 65 20 73 65 72 76 65 72 20 69 66 20 68 the server if h
1000: 61 76 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 ave connection i
1010: 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 64 61 74 nfo..(let* ((dat
1020: 20 20 20 20 20 28 63 61 73 65 20 2a 74 72 61 6e (case *tran
1030: 73 70 6f 72 74 2d 74 79 70 65 2a 0a 09 09 09 20 sport-type*....
1040: 20 28 28 68 74 74 70 29 28 63 6f 6e 64 69 74 69 ((http)(conditi
1050: 6f 6e 2d 63 61 73 65 0a 09 09 09 09 20 20 28 68 on-case..... (h
1060: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
1070: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
1080: 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e ceive run-id con
1090: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 nection-info cmd
10a0: 20 70 61 72 61 6d 73 29 0a 09 09 09 09 20 20 28 params)..... (
10b0: 28 63 6f 6d 6d 66 61 69 6c 29 28 76 65 63 74 6f (commfail)(vecto
10c0: 72 20 23 66 20 22 63 6f 6d 6d 75 6e 69 63 61 74 r #f "communicat
10d0: 69 6f 6e 73 20 66 61 69 6c 22 29 29 0a 09 09 09 ions fail"))....
10e0: 09 20 20 28 28 65 78 6e 29 28 76 65 63 74 6f 72 . ((exn)(vector
10f0: 20 23 66 20 22 6f 74 68 65 72 20 66 61 69 6c 22 #f "other fail"
1100: 29 29 29 29 0a 09 09 09 20 20 3b 3b 20 28 28 6e )))).... ;; ((n
1110: 6d 73 67 29 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 msg)(condition-c
1120: 61 73 65 0a 09 09 09 20 20 3b 3b 20 20 20 20 20 ase.... ;;
1130: 20 20 20 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 (nmsg-transp
1140: 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 ort:client-api-s
1150: 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d end-receive run-
1160: 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e id connection-in
1170: 66 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 09 fo cmd params)..
1180: 09 09 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 .. ;; (
1190: 28 74 69 6d 65 6f 75 74 29 28 76 65 63 74 6f 72 (timeout)(vector
11a0: 20 23 66 20 22 74 69 6d 65 6f 75 74 20 74 61 6c #f "timeout tal
11b0: 6b 69 6e 67 20 74 6f 20 73 65 72 76 65 72 22 29 king to server")
11c0: 29 29 29 0a 09 09 09 20 20 28 65 6c 73 65 20 20 ))).... (else
11d0: 28 65 78 69 74 29 29 29 29 0a 09 20 20 20 20 20 (exit))))..
11e0: 20 20 28 73 75 63 63 65 73 73 20 28 69 66 20 28 (success (if (
11f0: 76 65 63 74 6f 72 3f 20 64 61 74 29 20 28 76 65 vector? dat) (ve
1200: 63 74 6f 72 2d 72 65 66 20 64 61 74 20 30 29 20 ctor-ref dat 0)
1210: 23 66 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 #f)).. (re
1220: 73 20 20 20 20 20 28 69 66 20 28 76 65 63 74 6f s (if (vecto
1230: 72 3f 20 64 61 74 29 20 28 76 65 63 74 6f 72 2d r? dat) (vector-
1240: 72 65 66 20 64 61 74 20 31 29 20 23 66 29 29 29 ref dat 1) #f)))
1250: 0a 09 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f .. (if (vector?
1260: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f connection-info
1270: 29 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 )(http-transport
1280: 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 :server-dat-upda
1290: 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 63 te-last-access c
12a0: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 29 29 onnection-info))
12b0: 0a 09 20 20 28 69 66 20 73 75 63 63 65 73 73 0a .. (if success.
12c0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
12d0: 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b ;; (mutex-unlock
12e0: 21 20 2a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d ! *send-receive-
12f0: 6d 75 74 65 78 2a 29 0a 09 09 28 63 61 73 65 20 mutex*)...(case
1300: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
1310: 20 0a 09 09 20 20 28 28 68 74 74 70 29 20 72 65 ... ((http) re
1320: 73 29 20 3b 3b 20 28 64 62 3a 73 74 72 69 6e 67 s) ;; (db:string
1330: 2d 3e 6f 62 6a 20 72 65 73 29 29 0a 09 09 20 20 ->obj res))...
1340: 3b 3b 20 28 28 6e 6d 73 67 29 20 72 65 73 29 0a ;; ((nmsg) res).
1350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1360: 20 20 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d )) ;; (vector-
1370: 72 65 66 20 72 65 73 20 31 29 29 29 0a 09 20 20 ref res 1)))..
1380: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 (begin ;; le
1390: 74 20 28 28 6e 65 77 2d 63 6f 6e 6e 65 63 74 69 t ((new-connecti
13a0: 6f 6e 2d 69 6e 66 6f 20 28 63 6c 69 65 6e 74 3a on-info (client:
13b0: 73 65 74 75 70 20 72 75 6e 2d 69 64 29 29 29 0a setup run-id))).
13c0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
13d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
13e0: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 43 6f rt* "WARNING: Co
13f0: 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 61 69 6c mmunication fail
1400: 65 64 2c 20 74 72 79 69 6e 67 20 63 61 6c 6c 20 ed, trying call
1410: 74 6f 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 to rmt:send-rece
1420: 69 76 65 20 61 67 61 69 6e 2e 22 29 0a 09 09 3b ive again.")...;
1430: 3b 20 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f ; (case *transpo
1440: 72 74 2d 74 79 70 65 2a 0a 09 09 3b 3b 20 20 20 rt-type*...;;
1450: 28 28 6e 6d 73 67 29 28 6e 6e 2d 63 6c 6f 73 65 ((nmsg)(nn-close
1460: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1470: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
1480: 73 6f 63 6b 65 74 20 63 6f 6e 6e 65 63 74 69 6f socket connectio
1490: 6e 2d 69 6e 66 6f 29 29 29 29 0a 09 09 28 68 61 n-info))))...(ha
14a0: 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 sh-table-delete!
14b0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e *runremote* run
14c0: 2d 69 64 29 20 3b 3b 20 64 6f 6e 27 74 20 6b 65 -id) ;; don't ke
14d0: 65 70 20 75 73 69 6e 67 20 74 68 65 20 73 61 6d ep using the sam
14e0: 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 09 09 3b e connection...;
14f0: 3b 20 4e 4f 54 45 3a 20 6b 69 6c 6c 69 6e 67 20 ; NOTE: killing
1500: 73 65 72 76 65 72 20 63 61 75 73 65 73 20 74 68 server causes th
1510: 69 73 20 70 72 6f 63 65 73 73 20 74 6f 20 62 6c is process to bl
1520: 6f 63 6b 20 66 6f 72 65 76 65 72 2e 20 4e 6f 20 ock forever. No
1530: 69 64 65 61 20 77 68 79 2e 20 44 65 63 20 32 2e idea why. Dec 2.
1540: 20 0a 09 09 3b 3b 20 28 69 66 20 28 65 71 3f 20 ...;; (if (eq?
1550: 28 6d 6f 64 75 6c 6f 20 61 74 74 65 6d 70 74 6e (modulo attemptn
1560: 75 6d 20 35 29 20 30 29 0a 09 09 3b 3b 20 20 20 um 5) 0)...;;
1570: 20 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 (tasks:kill-se
1580: 72 76 65 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d rver-run-id run-
1590: 69 64 20 74 61 67 3a 20 22 61 70 69 2d 73 65 6e id tag: "api-sen
15a0: 64 2d 72 65 63 65 69 76 65 2d 66 61 69 6c 65 64 d-receive-failed
15b0: 22 29 29 0a 09 09 3b 3b 20 28 6d 75 74 65 78 2d "))...;; (mutex-
15c0: 75 6e 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 72 65 unlock! *send-re
15d0: 63 65 69 76 65 2d 6d 75 74 65 78 2a 29 20 3b 3b ceive-mutex*) ;;
15e0: 20 63 6c 6f 73 65 20 74 68 65 20 6d 75 74 65 78 close the mutex
15f0: 20 68 65 72 65 20 74 6f 20 61 6c 6c 6f 77 20 6f here to allow o
1600: 74 68 65 72 20 74 68 72 65 61 64 73 20 61 63 63 ther threads acc
1610: 65 73 73 20 74 6f 20 63 6f 6d 6d 75 6e 69 63 61 ess to communica
1620: 74 69 6f 6e 73 0a 09 09 28 74 61 73 6b 73 3a 73 tions...(tasks:s
1630: 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f tart-and-wait-fo
1640: 72 2d 73 65 72 76 65 72 20 28 74 61 73 6b 73 3a r-server (tasks:
1650: 6f 70 65 6e 2d 64 62 29 20 72 75 6e 2d 69 64 20 open-db) run-id
1660: 31 35 29 0a 09 09 3b 3b 20 28 6e 6d 73 67 2d 74 15)...;; (nmsg-t
1670: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
1680: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
1690: 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 run-id connecti
16a0: 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 70 61 72 61 on-info cmd para
16b0: 6d 20 72 65 6d 74 72 69 65 73 3a 20 28 2d 20 72 m remtries: (- r
16c0: 65 6d 74 72 69 65 73 20 31 29 29 29 29 29 29 0a emtries 1)))))).
16d0: 0a 09 09 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 72 20 ...;; no longer
16e0: 6b 69 6c 6c 69 6e 67 20 74 68 65 20 73 65 72 76 killing the serv
16f0: 65 72 20 69 6e 20 68 74 74 70 2d 74 72 61 6e 73 er in http-trans
1700: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d port:client-api-
1710: 73 65 6e 64 2d 72 65 63 65 69 76 65 0a 09 09 3b send-receive...;
1720: 3b 20 6d 61 79 20 6b 69 6c 6c 20 69 74 20 68 65 ; may kill it he
1730: 72 65 20 62 75 74 20 77 68 61 74 20 61 72 65 20 re but what are
1740: 74 68 65 20 63 72 69 74 65 72 69 61 3f 0a 09 09 the criteria?...
1750: 3b 3b 20 73 74 61 72 74 20 77 69 74 68 20 74 68 ;; start with th
1760: 72 65 65 20 63 61 6c 6c 73 20 74 68 65 6e 20 6b ree calls then k
1770: 69 6c 6c 20 73 65 72 76 65 72 0a 09 09 3b 3b 20 ill server...;;
1780: 28 69 66 20 28 65 71 3f 20 61 74 74 65 6d 70 74 (if (eq? attempt
1790: 6e 75 6d 20 33 29 28 74 61 73 6b 73 3a 6b 69 6c num 3)(tasks:kil
17a0: 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d 69 64 20 l-server-run-id
17b0: 72 75 6e 2d 69 64 29 29 0a 09 09 3b 3b 20 28 74 run-id))...;; (t
17c0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a hread-sleep! 2).
17d0: 09 09 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 ..(rmt:send-rece
17e0: 69 76 65 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 ive cmd run-id p
17f0: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
1800: 3a 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 : (+ attemptnum
1810: 31 29 29 29 29 29 0a 09 3b 3b 20 6e 6f 20 63 6f 1)))))..;; no co
1820: 6e 6e 65 63 74 69 6f 6e 20 69 6e 66 6f 3f 20 74 nnection info? t
1830: 72 79 20 74 6f 20 73 74 61 72 74 20 61 20 73 65 ry to start a se
1840: 72 76 65 72 2c 20 6f 72 20 61 63 63 65 73 73 20 rver, or access
1850: 6c 6f 63 61 6c 6c 79 20 69 66 20 6e 6f 0a 09 3b locally if no..;
1860: 3b 20 73 65 72 76 65 72 20 61 6e 64 20 74 68 65 ; server and the
1870: 20 71 75 65 72 79 20 69 73 20 72 65 61 64 2d 6f query is read-o
1880: 6e 6c 79 0a 09 3b 3b 0a 09 3b 3b 20 4e 6f 74 65 nly..;;..;; Note
1890: 3a 20 54 68 65 20 74 61 73 6b 73 20 64 62 20 77 : The tasks db w
18a0: 61 73 20 63 68 65 63 6b 65 64 20 66 6f 72 20 61 as checked for a
18b0: 20 73 65 72 76 65 72 20 69 6e 20 73 74 61 72 74 server in start
18c0: 69 6e 67 20 6d 6f 64 65 20 69 6e 20 74 68 65 20 ing mode in the
18d0: 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 rmt:get-connecti
18e0: 6f 6e 2d 69 6e 66 6f 20 63 61 6c 6c 0a 09 3b 3b on-info call..;;
18f0: 0a 09 28 69 66 20 28 61 6e 64 20 28 3c 20 61 74 ..(if (and (< at
1900: 74 65 6d 70 74 6e 75 6d 20 31 35 29 0a 09 09 20 temptnum 15)...
1910: 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a (member cmd api:
1920: 77 72 69 74 65 2d 71 75 65 72 69 65 73 29 29 0a write-queries)).
1930: 09 20 20 20 20 28 6c 65 74 20 28 28 66 61 73 74 . (let ((fast
1940: 73 74 61 72 74 20 28 63 6f 6e 66 69 67 66 3a 6c start (configf:l
1950: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
1960: 2a 20 22 73 65 72 76 65 72 22 20 22 66 61 73 74 * "server" "fast
1970: 73 74 61 72 74 22 29 29 29 0a 09 20 20 20 20 20 start")))..
1980: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c (hash-table-del
1990: 65 74 65 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a ete! *runremote*
19a0: 20 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 20 20 run-id)..
19b0: 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b ;; (mutex-unlock
19c0: 21 20 2a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d ! *send-receive-
19d0: 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 20 20 28 mutex*).. (
19e0: 69 66 20 28 61 6e 64 20 66 61 73 74 73 74 61 72 if (and faststar
19f0: 74 20 28 65 71 75 61 6c 3f 20 66 61 73 74 73 74 t (equal? fastst
1a00: 61 72 74 20 22 6e 6f 22 29 29 0a 09 09 20 20 28 art "no"))... (
1a10: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 74 61 73 begin... (tas
1a20: 6b 73 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 ks:start-and-wai
1a30: 74 2d 66 6f 72 2d 73 65 72 76 65 72 20 28 64 62 t-for-server (db
1a40: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 :delay-if-busy (
1a50: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 tasks:open-db))
1a60: 72 75 6e 2d 69 64 20 31 30 29 0a 09 09 20 20 20 run-id 10)...
1a70: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
1a80: 28 72 61 6e 64 6f 6d 20 35 29 29 20 3b 3b 20 67 (random 5)) ;; g
1a90: 69 76 65 20 73 6f 6d 65 20 74 69 6d 65 20 74 6f ive some time to
1aa0: 20 73 65 74 74 6c 65 20 61 6e 64 20 6d 69 6e 69 settle and mini
1ab0: 6d 69 7a 65 20 63 6f 6c 6c 69 73 6f 6e 3f 0a 09 mize collison?..
1ac0: 09 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 . (rmt:send-r
1ad0: 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 eceive cmd rid p
1ae0: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
1af0: 3a 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 : (+ attemptnum
1b00: 31 29 29 29 0a 09 09 20 20 28 6c 65 74 20 28 28 1)))... (let ((
1b10: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
1b20: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
1b30: 29 29 0a 09 09 09 28 6d 61 78 2d 71 75 65 72 79 ))....(max-query
1b40: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
1b50: 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c r (or (configf:l
1b60: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
1b70: 2a 20 22 73 65 72 76 65 72 22 20 22 73 65 72 76 * "server" "serv
1b80: 65 72 2d 71 75 65 72 79 2d 74 68 72 65 73 68 6f er-query-thresho
1b90: 6c 64 22 29 0a 09 09 09 09 09 09 09 22 33 30 30 ld")........"300
1ba0: 22 29 29 29 0a 09 09 09 28 6e 65 77 72 65 73 20 ")))....(newres
1bb0: 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 (rmt:open-qr
1bc0: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 y-close-locally
1bd0: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
1be0: 73 29 29 29 0a 09 09 20 20 20 20 28 6c 65 74 20 s)))... (let
1bf0: 28 28 64 65 6c 74 61 20 28 2d 20 28 63 75 72 72 ((delta (- (curr
1c00: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
1c10: 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 29 0a ) start-time))).
1c20: 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 64 .. (if (> d
1c30: 65 6c 74 61 20 6d 61 78 2d 71 75 65 72 79 29 0a elta max-query).
1c40: 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 ... (begin....
1c50: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1c60: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
1c70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 log-port* "Start
1c80: 69 6e 67 20 73 65 72 76 65 72 20 61 73 20 71 75 ing server as qu
1c90: 65 72 79 20 74 69 6d 65 20 22 20 64 65 6c 74 61 ery time " delta
1ca0: 20 22 20 69 73 20 6f 76 65 72 20 74 68 65 20 6c " is over the l
1cb0: 69 6d 69 74 20 6f 66 20 22 20 6d 61 78 2d 71 75 imit of " max-qu
1cc0: 65 72 79 29 0a 09 09 09 20 20 20 20 28 73 65 72 ery).... (ser
1cd0: 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 72 75 6e ver:kind-run run
1ce0: 2d 69 64 29 29 29 0a 09 09 20 20 20 20 20 20 3b -id)))... ;
1cf0: 3b 20 72 65 74 75 72 6e 20 74 68 65 20 72 65 73 ; return the res
1d00: 75 6c 74 21 0a 09 09 20 20 20 20 20 20 6e 65 77 ult!... new
1d10: 72 65 73 29 0a 09 09 20 20 20 20 29 29 29 0a 09 res)... )))..
1d20: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
1d30: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
1d40: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
1d50: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 6f lt-log-port* "Co
1d60: 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 61 69 6c mmunication fail
1d70: 65 64 21 22 29 0a 09 20 20 20 20 20 20 3b 3b 20 ed!").. ;;
1d80: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
1d90: 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 send-receive-mut
1da0: 65 78 2a 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 ex*).. ;; (
1db0: 65 78 69 74 29 0a 09 20 20 20 20 20 20 28 72 6d exit).. (rm
1dc0: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
1dd0: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 6e -locally cmd run
1de0: 2d 69 64 20 70 61 72 61 6d 73 29 0a 09 20 20 20 -id params)..
1df0: 20 20 20 29 29 29 29 29 0a 0a 28 64 65 66 69 6e )))))..(defin
1e00: 65 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 64 62 e (rmt:update-db
1e10: 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 20 72 61 -stats run-id ra
1e20: 77 63 6d 64 20 70 61 72 61 6d 73 20 64 75 72 61 wcmd params dura
1e30: 74 69 6f 6e 29 0a 20 20 28 6d 75 74 65 78 2d 6c tion). (mutex-l
1e40: 6f 63 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d ock! *db-stats-m
1e50: 75 74 65 78 2a 29 0a 20 20 28 68 61 6e 64 6c 65 utex*). (handle
1e60: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
1e70: 78 6e 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 20 xn. (begin.
1e80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
1e90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1ea0: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 74 rt* "WARNING: st
1eb0: 61 74 73 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 66 ats collection f
1ec0: 61 69 6c 65 64 20 69 6e 20 75 70 64 61 74 65 2d ailed in update-
1ed0: 64 62 2d 73 74 61 74 73 22 29 0a 20 20 20 20 20 db-stats").
1ee0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1ef0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1f00: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
1f10: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
1f20: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
1f30: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
1f40: 29 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 65 ). (print "e
1f50: 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d xn=" (condition-
1f60: 3e 6c 69 73 74 20 65 78 6e 29 29 0a 20 20 20 20 >list exn)).
1f70: 20 23 66 29 20 3b 3b 20 69 66 20 74 68 69 73 20 #f) ;; if this
1f80: 66 61 69 6c 73 20 77 65 20 64 6f 6e 27 74 20 63 fails we don't c
1f90: 61 72 65 2c 20 69 74 20 69 73 20 6a 75 73 74 20 are, it is just
1fa0: 73 74 61 74 73 0a 20 20 20 28 6c 65 74 2a 20 28 stats. (let* (
1fb0: 28 63 6d 64 20 20 20 20 20 20 28 63 6f 6e 63 20 (cmd (conc
1fc0: 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 "run-id=" run-id
1fd0: 20 22 20 22 20 28 69 66 20 28 65 71 3f 20 72 61 " " (if (eq? ra
1fe0: 77 63 6d 64 20 27 67 65 6e 65 72 61 6c 2d 63 61 wcmd 'general-ca
1ff0: 6c 6c 29 20 28 63 61 72 20 70 61 72 61 6d 73 29 ll) (car params)
2000: 20 72 61 77 63 6d 64 29 29 29 0a 09 20 20 28 73 rawcmd))).. (s
2010: 74 61 74 2d 76 65 63 20 28 68 61 73 68 2d 74 61 tat-vec (hash-ta
2020: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2030: 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 20 23 *db-stats* cmd #
2040: 66 29 29 29 0a 20 20 20 20 20 28 69 66 20 28 6e f))). (if (n
2050: 6f 74 20 28 76 65 63 74 6f 72 3f 20 73 74 61 74 ot (vector? stat
2060: 2d 76 65 63 29 29 0a 09 20 28 6c 65 74 20 28 28 -vec)).. (let ((
2070: 6e 65 77 76 65 63 20 28 76 65 63 74 6f 72 20 30 newvec (vector 0
2080: 20 30 29 29 29 0a 09 20 20 20 28 68 61 73 68 2d 0))).. (hash-
2090: 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 62 2d 73 table-set! *db-s
20a0: 74 61 74 73 2a 20 63 6d 64 20 6e 65 77 76 65 63 tats* cmd newvec
20b0: 29 0a 09 20 20 20 28 73 65 74 21 20 73 74 61 74 ).. (set! stat
20c0: 2d 76 65 63 20 6e 65 77 76 65 63 29 29 29 0a 20 -vec newvec))).
20d0: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
20e0: 20 73 74 61 74 2d 76 65 63 20 30 20 28 2b 20 28 stat-vec 0 (+ (
20f0: 76 65 63 74 6f 72 2d 72 65 66 20 73 74 61 74 2d vector-ref stat-
2100: 76 65 63 20 30 29 20 31 29 29 0a 20 20 20 20 20 vec 0) 1)).
2110: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 73 74 61 (vector-set! sta
2120: 74 2d 76 65 63 20 31 20 28 2b 20 28 76 65 63 74 t-vec 1 (+ (vect
2130: 6f 72 2d 72 65 66 20 73 74 61 74 2d 76 65 63 20 or-ref stat-vec
2140: 31 29 20 64 75 72 61 74 69 6f 6e 29 29 29 29 0a 1) duration)))).
2150: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2160: 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 *db-stats-mutex
2170: 2a 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 *))...(define (r
2180: 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 61 74 mt:print-db-stat
2190: 73 29 0a 20 20 28 6c 65 74 20 28 28 66 6d 74 73 s). (let ((fmts
21a0: 74 72 20 22 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 tr "~40a~7-d~9-d
21b0: 7e 32 30 2c 32 2d 66 22 29 29 20 3b 3b 20 22 7e ~20,2-f")) ;; "~
21c0: 32 30 2c 32 2d 66 22 0a 20 20 20 20 28 64 65 62 20,2-f". (deb
21d0: 75 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 65 66 ug:print 18 *def
21e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
21f0: 44 42 20 53 74 61 74 73 5c 6e 3d 3d 3d 3d 3d 3d DB Stats\n======
2200: 3d 3d 22 29 0a 20 20 20 20 28 64 65 62 75 67 3a =="). (debug:
2210: 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c print 18 *defaul
2220: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 t-log-port* (for
2230: 6d 61 74 20 23 66 20 22 7e 34 30 61 7e 38 61 7e mat #f "~40a~8a~
2240: 31 30 61 7e 31 30 61 22 20 22 43 6d 64 22 20 22 10a~10a" "Cmd" "
2250: 43 6f 75 6e 74 22 20 22 54 6f 74 54 69 6d 65 22 Count" "TotTime"
2260: 20 22 41 76 67 22 29 29 0a 20 20 20 20 28 66 6f "Avg")). (fo
2270: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
2280: 63 6d 64 29 0a 09 09 28 6c 65 74 20 28 28 63 6d cmd)...(let ((cm
2290: 64 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c d-dat (hash-tabl
22a0: 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a e-ref *db-stats*
22b0: 20 63 6d 64 29 29 29 0a 09 09 20 20 28 64 65 62 cmd)))... (deb
22c0: 75 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 65 66 ug:print 18 *def
22d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 ault-log-port* (
22e0: 66 6f 72 6d 61 74 20 23 66 20 66 6d 74 73 74 72 format #f fmtstr
22f0: 20 63 6d 64 20 28 76 65 63 74 6f 72 2d 72 65 66 cmd (vector-ref
2300: 20 63 6d 64 2d 64 61 74 20 30 29 20 28 76 65 63 cmd-dat 0) (vec
2310: 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 tor-ref cmd-dat
2320: 31 29 20 28 2f 20 28 76 65 63 74 6f 72 2d 72 65 1) (/ (vector-re
2330: 66 20 63 6d 64 2d 64 61 74 20 31 29 28 76 65 63 f cmd-dat 1)(vec
2340: 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 tor-ref cmd-dat
2350: 30 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 0)))))).. (
2360: 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 sort (hash-table
2370: 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 73 2a -keys *db-stats*
2380: 29 0a 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 )... (lambda
2390: 28 61 20 62 29 0a 09 09 20 20 20 20 20 20 28 3e (a b)... (>
23a0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 (vector-ref (ha
23b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 sh-table-ref *db
23c0: 2d 73 74 61 74 73 2a 20 61 29 20 30 29 0a 09 09 -stats* a) 0)...
23d0: 09 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 . (vector-ref (h
23e0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 ash-table-ref *d
23f0: 62 2d 73 74 61 74 73 2a 20 62 29 20 30 29 29 29 b-stats* b) 0)))
2400: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
2410: 6d 74 3a 67 65 74 2d 6d 61 78 2d 71 75 65 72 79 mt:get-max-query
2420: 2d 61 76 65 72 61 67 65 20 72 75 6e 2d 69 64 29 -average run-id)
2430: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
2440: 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a *db-stats-mutex*
2450: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 6b ). (let* ((runk
2460: 65 79 20 28 63 6f 6e 63 20 22 72 75 6e 2d 69 64 ey (conc "run-id
2470: 3d 22 20 72 75 6e 2d 69 64 20 22 20 22 29 29 0a =" run-id " ")).
2480: 09 20 28 63 6d 64 73 20 20 20 28 66 69 6c 74 65 . (cmds (filte
2490: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
24a0: 09 20 20 20 28 73 75 62 73 74 72 69 6e 67 2d 69 . (substring-i
24b0: 6e 64 65 78 20 72 75 6e 6b 65 79 20 78 29 29 0a ndex runkey x)).
24c0: 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ... (hash-table-
24d0: 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 keys *db-stats*)
24e0: 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 69 66 )).. (res (if
24f0: 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 09 09 (null? cmds)...
2500: 20 20 20 20 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 (cons 'none
2510: 20 30 29 0a 09 09 20 20 20 20 20 28 6c 65 74 20 0)... (let
2520: 6c 6f 6f 70 20 28 28 63 6d 64 20 28 63 61 72 20 loop ((cmd (car
2530: 63 6d 64 73 29 29 0a 09 09 09 09 28 74 61 6c 20 cmds)).....(tal
2540: 28 63 64 72 20 63 6d 64 73 29 29 0a 09 09 09 09 (cdr cmds)).....
2550: 28 6d 61 78 2d 63 6d 64 20 28 63 61 72 20 63 6d (max-cmd (car cm
2560: 64 73 29 29 0a 09 09 09 09 28 72 65 73 20 30 29 ds)).....(res 0)
2570: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a )... (let*
2580: 20 28 28 63 6d 64 2d 64 61 74 20 28 68 61 73 68 ((cmd-dat (hash
2590: 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 -table-ref *db-s
25a0: 74 61 74 73 2a 20 63 6d 64 29 29 0a 09 09 09 20 tats* cmd))....
25b0: 20 20 20 20 20 28 74 6f 74 20 20 20 20 20 28 76 (tot (v
25c0: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
25d0: 74 20 30 29 29 0a 09 09 09 20 20 20 20 20 20 28 t 0)).... (
25e0: 63 75 72 72 61 76 67 20 28 2f 20 28 76 65 63 74 curravg (/ (vect
25f0: 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 31 or-ref cmd-dat 1
2600: 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d ) (vector-ref cm
2610: 64 2d 64 61 74 20 30 29 29 29 20 3b 3b 20 63 6f d-dat 0))) ;; co
2620: 75 6e 74 20 69 73 20 6e 65 76 65 72 20 7a 65 72 unt is never zer
2630: 6f 20 62 79 20 63 6f 6e 73 74 72 75 63 74 69 6f o by constructio
2640: 6e 0a 09 09 09 20 20 20 20 20 20 28 63 75 72 72 n.... (curr
2650: 6d 61 78 20 28 6d 61 78 20 72 65 73 20 63 75 72 max (max res cur
2660: 72 61 76 67 29 29 0a 09 09 09 20 20 20 20 20 20 ravg))....
2670: 28 6e 65 77 6d 61 78 2d 63 6d 64 20 28 69 66 20 (newmax-cmd (if
2680: 28 3e 20 63 75 72 72 61 76 67 20 72 65 73 29 20 (> curravg res)
2690: 63 6d 64 20 6d 61 78 2d 63 6d 64 29 29 29 0a 09 cmd max-cmd)))..
26a0: 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 .. (if (null? ta
26b0: 6c 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 l).... (if (
26c0: 3e 20 74 6f 74 20 31 30 29 0a 09 09 09 09 20 28 > tot 10)..... (
26d0: 63 6f 6e 73 20 6e 65 77 6d 61 78 2d 63 6d 64 20 cons newmax-cmd
26e0: 63 75 72 72 6d 61 78 29 0a 09 09 09 09 20 28 63 currmax)..... (c
26f0: 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 29 0a 09 09 ons 'none 0))...
2700: 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 . (loop (car
2710: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e tal)(cdr tal) n
2720: 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 ewmax-cmd currma
2730: 78 29 29 29 29 29 29 29 0a 20 20 20 20 28 6d 75 x))))))). (mu
2740: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d tex-unlock! *db-
2750: 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 stats-mutex*).
2760: 20 20 72 65 73 29 29 0a 09 20 20 0a 28 64 65 66 res)).. .(def
2770: 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 ine (rmt:open-qr
2780: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 y-close-locally
2790: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
27a0: 73 20 23 21 6b 65 79 20 28 72 65 6d 72 65 74 72 s #!key (remretr
27b0: 69 65 73 20 35 29 29 0a 20 20 28 6c 65 74 2a 20 ies 5)). (let*
27c0: 28 28 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 6c ((dbstruct-local
27d0: 20 28 69 66 20 2a 64 62 73 74 72 75 63 74 2d 64 (if *dbstruct-d
27e0: 62 2a 0a 09 09 09 20 20 20 20 20 2a 64 62 73 74 b*.... *dbst
27f0: 72 75 63 74 2d 64 62 2a 0a 09 09 09 20 20 20 20 ruct-db*....
2800: 20 28 6c 65 74 2a 20 28 28 64 62 64 69 72 20 28 (let* ((dbdir (
2810: 64 62 3a 64 62 66 69 6c 65 2d 70 61 74 68 20 23 db:dbfile-path #
2820: 66 29 29 20 3b 3b 20 20 28 63 6f 6e 63 20 20 20 f)) ;; (conc
2830: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
2840: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
2850: 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 tup" "linktree")
2860: 20 22 2f 2e 64 62 22 29 29 0a 09 09 09 09 20 20 "/.db")).....
2870: 20 20 28 64 62 20 28 6d 61 6b 65 2d 64 62 72 3a (db (make-dbr:
2880: 64 62 73 74 72 75 63 74 20 70 61 74 68 3a 20 20 dbstruct path:
2890: 64 62 64 69 72 20 6c 6f 63 61 6c 3a 20 23 74 29 dbdir local: #t)
28a0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 73 65 )).... (se
28b0: 74 21 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a t! *dbstruct-db*
28c0: 20 64 62 29 0a 09 09 09 20 20 20 20 20 20 20 64 db).... d
28d0: 62 29 29 29 0a 09 20 28 64 62 2d 66 69 6c 65 2d b))).. (db-file-
28e0: 70 61 74 68 20 20 20 28 64 62 3a 64 62 66 69 6c path (db:dbfil
28f0: 65 2d 70 61 74 68 20 30 29 29 0a 09 20 3b 3b 20 e-path 0)).. ;;
2900: 28 72 65 61 64 2d 6f 6e 6c 79 20 20 20 20 20 20 (read-only
2910: 28 6e 6f 74 20 28 66 69 6c 65 2d 72 65 61 64 2d (not (file-read-
2920: 61 63 63 65 73 73 3f 20 64 62 2d 66 69 6c 65 2d access? db-file-
2930: 70 61 74 68 29 29 29 0a 09 20 28 73 74 61 72 74 path))).. (start
2940: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
2950: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
2960: 29 0a 09 20 28 72 65 73 64 61 74 20 20 20 20 20 ).. (resdat
2970: 20 20 20 20 28 61 70 69 3a 65 78 65 63 75 74 65 (api:execute
2980: 2d 72 65 71 75 65 73 74 73 20 64 62 73 74 72 75 -requests dbstru
2990: 63 74 2d 6c 6f 63 61 6c 20 28 76 65 63 74 6f 72 ct-local (vector
29a0: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
29b0: 20 63 6d 64 29 20 70 61 72 61 6d 73 29 29 29 0a cmd) params))).
29c0: 09 20 28 73 75 63 63 65 73 73 20 20 20 20 20 20 . (success
29d0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 (vector-ref re
29e0: 73 64 61 74 20 30 29 29 0a 09 20 28 72 65 73 20 sdat 0)).. (res
29f0: 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 (vect
2a00: 6f 72 2d 72 65 66 20 72 65 73 64 61 74 20 31 29 or-ref resdat 1)
2a10: 29 0a 09 20 28 64 75 72 61 74 69 6f 6e 20 20 20 ).. (duration
2a20: 20 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (- (current-
2a30: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 milliseconds) st
2a40: 61 72 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 art))). (if (
2a50: 6e 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 69 not success)..(i
2a60: 66 20 28 3e 20 72 65 6d 72 65 74 72 69 65 73 20 f (> remretries
2a70: 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 0).. (begin..
2a80: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2a90: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
2aa0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c ult-log-port* "l
2ab0: 6f 63 61 6c 20 71 75 65 72 79 20 66 61 69 6c 65 ocal query faile
2ac0: 64 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e 2e d. Trying again.
2ad0: 22 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 ").. (threa
2ae0: 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 6e d-sleep! (/ (ran
2af0: 64 6f 6d 20 35 30 30 30 29 20 31 30 30 30 29 29 dom 5000) 1000))
2b00: 20 3b 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d 20 ;; some random
2b10: 64 65 6c 61 79 20 0a 09 20 20 20 20 20 20 28 72 delay .. (r
2b20: 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 mt:open-qry-clos
2b30: 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 e-locally cmd ru
2b40: 6e 2d 69 64 20 70 61 72 61 6d 73 20 72 65 6d 72 n-id params remr
2b50: 65 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 72 65 etries: (- remre
2b60: 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 tries 1)))..
2b70: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
2b80: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
2b90: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2ba0: 70 6f 72 74 2a 20 22 74 6f 6f 20 6d 61 6e 79 20 port* "too many
2bb0: 72 65 74 72 69 65 73 20 69 6e 20 72 6d 74 3a 6f retries in rmt:o
2bc0: 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f pen-qry-close-lo
2bd0: 63 61 6c 6c 79 2c 20 67 69 76 69 6e 67 20 75 70 cally, giving up
2be0: 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 0a 09 ").. #f))..
2bf0: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 72 6d (begin.. ;; (rm
2c00: 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 74 t:update-db-stat
2c10: 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 70 61 72 s run-id cmd par
2c20: 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 09 20 ams duration)..
2c30: 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 72 75 ;; mark this ru
2c40: 6e 20 61 73 20 64 69 72 74 79 20 69 66 20 74 68 n as dirty if th
2c50: 69 73 20 77 61 73 20 61 20 77 72 69 74 65 0a 09 is was a write..
2c60: 20 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 (if (not (memb
2c70: 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d er cmd api:read-
2c80: 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 0a 09 only-queries))..
2c90: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 (let ((sta
2ca0: 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 rt-time (current
2cb0: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 6d -seconds)))...(m
2cc0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d utex-lock! *db-m
2cd0: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
2ce0: 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e 6f 74 20 )...;; (if (not
2cf0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2d00: 64 65 66 61 75 6c 74 20 2a 64 62 2d 6c 6f 63 61 default *db-loca
2d10: 6c 2d 73 79 6e 63 2a 20 72 75 6e 2d 69 64 20 23 l-sync* run-id #
2d20: 66 29 29 0a 09 09 3b 3b 20 6a 75 73 74 20 73 65 f))...;; just se
2d30: 74 20 69 74 20 65 76 65 72 79 20 74 69 6d 65 2e t it every time.
2d40: 20 49 73 20 61 20 77 72 69 74 65 20 6d 6f 72 65 Is a write more
2d50: 20 65 78 70 65 6e 73 69 76 65 20 74 68 61 6e 20 expensive than
2d60: 61 20 72 65 61 64 20 61 6e 64 20 64 6f 65 73 20 a read and does
2d70: 69 74 20 6d 61 74 74 65 72 3f 0a 09 09 28 68 61 it matter?...(ha
2d80: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 sh-table-set! *d
2d90: 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a 20 28 6f b-local-sync* (o
2da0: 72 20 72 75 6e 2d 69 64 20 30 29 20 73 74 61 72 r run-id 0) star
2db0: 74 2d 74 69 6d 65 29 20 3b 3b 20 74 68 65 20 6f t-time) ;; the o
2dc0: 6c 64 65 73 74 20 22 77 72 69 74 65 22 0a 09 09 ldest "write"...
2dd0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
2de0: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
2df0: 74 65 78 2a 29 29 29 0a 09 20 20 72 65 73 29 29 tex*))).. res))
2e00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
2e10: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f :send-receive-no
2e20: 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 -auto-client-set
2e30: 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e up connection-in
2e40: 66 6f 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 fo cmd run-id pa
2e50: 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 rams). (let* ((
2e60: 72 75 6e 2d 69 64 20 20 20 28 69 66 20 72 75 6e run-id (if run
2e70: 2d 69 64 20 72 75 6e 2d 69 64 20 30 29 29 0a 09 -id run-id 0))..
2e80: 20 3b 3b 20 28 6a 70 61 72 61 6d 73 20 20 28 64 ;; (jparams (d
2e90: 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 70 61 b:obj->string pa
2ea0: 72 61 6d 73 29 29 20 3b 3b 20 28 72 6d 74 3a 64 rams)) ;; (rmt:d
2eb0: 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 20 70 61 72 at->json-str par
2ec0: 61 6d 73 29 29 0a 09 20 28 72 65 73 20 20 09 20 ams)).. (res .
2ed0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
2ee0: 69 6f 6e 73 0a 09 09 20 20 20 20 65 78 6e 0a 09 ions... exn..
2ef0: 09 20 20 20 20 23 66 0a 09 09 20 20 20 20 28 68 . #f... (h
2f00: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2f10: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
2f20: 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e ceive run-id con
2f30: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 nection-info cmd
2f40: 20 70 61 72 61 6d 73 29 29 29 29 0a 3b 3b 09 09 params)))).;;..
2f50: 20 20 20 20 28 28 63 6f 6d 6d 66 61 69 6c 29 20 ((commfail)
2f60: 28 76 65 63 74 6f 72 20 23 66 20 22 63 6f 6d 6d (vector #f "comm
2f70: 75 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 6c 22 unications fail"
2f80: 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 ))))). (if (a
2f90: 6e 64 20 72 65 73 20 28 76 65 63 74 6f 72 2d 72 nd res (vector-r
2fa0: 65 66 20 72 65 73 20 30 29 29 0a 09 28 76 65 63 ef res 0))..(vec
2fb0: 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 3b tor-ref res 1) ;
2fc0: 3b 3b 20 59 45 53 21 21 20 54 48 49 53 20 49 53 ;; YES!! THIS IS
2fd0: 20 43 4f 52 52 45 43 54 21 21 20 43 48 41 4e 47 CORRECT!! CHANG
2fe0: 45 20 49 54 20 48 45 52 45 2c 20 54 48 45 4e 20 E IT HERE, THEN
2ff0: 43 48 41 4e 47 45 20 72 6d 74 3a 73 65 6e 64 2d CHANGE rmt:send-
3000: 72 65 63 65 69 76 65 20 41 4c 53 4f 21 21 21 0a receive ALSO!!!.
3010: 09 23 66 29 29 29 0a 3b 3b 20 09 28 64 62 3a 73 .#f))).;; .(db:s
3020: 74 72 69 6e 67 2d 3e 6f 62 6a 20 28 76 65 63 74 tring->obj (vect
3030: 6f 72 2d 72 65 66 20 64 61 74 20 31 29 29 0a 3b or-ref dat 1)).;
3040: 3b 20 09 28 62 65 67 69 6e 0a 3b 3b 20 09 20 20 ; .(begin.;; .
3050: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
3060: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
3070: 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e g-port* "rmt:sen
3080: 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 d-receive-no-aut
3090: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 66 o-client-setup f
30a0: 61 69 6c 65 64 2c 20 61 74 74 65 6d 70 74 69 6e ailed, attemptin
30b0: 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 2e 20 47 g to continue. G
30c0: 6f 74 20 22 20 64 61 74 29 0a 3b 3b 20 09 20 20 ot " dat).;; .
30d0: 64 61 74 29 29 29 29 0a 0a 3b 3b 20 57 72 61 70 dat))))..;; Wrap
30e0: 20 6a 73 6f 6e 20 6c 69 62 72 61 72 79 20 66 6f json library fo
30f0: 72 20 73 74 72 69 6e 67 73 20 28 77 68 79 20 74 r strings (why t
3100: 68 65 20 70 6f 72 74 73 20 63 72 61 70 20 69 6e he ports crap in
3110: 20 74 68 65 20 66 69 72 73 74 20 70 6c 61 63 65 the first place
3120: 3f 29 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ?).(define (rmt:
3130: 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 20 64 61 dat->json-str da
3140: 74 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 75 t). (with-outpu
3150: 74 2d 74 6f 2d 73 74 72 69 6e 67 20 0a 20 20 20 t-to-string .
3160: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
3170: 20 20 28 6a 73 6f 6e 2d 77 72 69 74 65 20 64 61 (json-write da
3180: 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 t))))..(define (
3190: 72 6d 74 3a 6a 73 6f 6e 2d 73 74 72 2d 3e 64 61 rmt:json-str->da
31a0: 74 20 6a 73 6f 6e 2d 73 74 72 29 0a 20 20 28 77 t json-str). (w
31b0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 ith-input-from-s
31c0: 74 72 69 6e 67 20 6a 73 6f 6e 2d 73 74 72 0a 20 tring json-str.
31d0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
31e0: 20 20 20 20 28 6a 73 6f 6e 2d 72 65 61 64 29 29 (json-read))
31f0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
3200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a ============.;;.
3240: 3b 3b 20 41 20 43 20 54 20 55 20 41 20 4c 20 20 ;; A C T U A L
3250: 20 41 20 50 20 49 20 20 20 43 20 41 20 4c 20 4c A P I C A L L
3260: 20 53 20 20 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d S .;;.;;======
3270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32b0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
32c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 ==========.;; S
3300: 20 45 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d E R V E R.;;===
3310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3350: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ===..(define (rm
3360: 74 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 75 t:kill-server ru
3370: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
3380: 64 2d 72 65 63 65 69 76 65 20 27 6b 69 6c 6c 2d d-receive 'kill-
3390: 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 28 6c server run-id (l
33a0: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 ist run-id)))..(
33b0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 74 61 72 define (rmt:star
33c0: 74 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 t-server run-id)
33d0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
33e0: 65 69 76 65 20 27 73 74 61 72 74 2d 73 65 72 76 eive 'start-serv
33f0: 65 72 20 30 20 28 6c 69 73 74 20 72 75 6e 2d 69 er 0 (list run-i
3400: 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d d)))..;;========
3410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
3450: 3b 20 20 4d 20 49 20 53 20 43 0a 3b 3b 3d 3d 3d ; M I S C.;;===
3460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ===..(define (rm
34b0: 74 3a 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 29 0a t:login run-id).
34c0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
34d0: 69 76 65 20 27 6c 6f 67 69 6e 20 72 75 6e 2d 69 ive 'login run-i
34e0: 64 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 d (list *toppath
34f0: 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 * megatest-versi
3500: 6f 6e 20 72 75 6e 2d 69 64 20 2a 6d 79 2d 63 6c on run-id *my-cl
3510: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 ient-signature*)
3520: 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6c 6f 67 69 ))..;; This logi
3530: 6e 20 64 6f 65 73 20 6e 6f 20 72 65 74 72 69 65 n does no retrie
3540: 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 s under the hood
3550: 20 2d 20 69 74 20 61 63 74 73 20 61 20 62 69 74 - it acts a bit
3560: 20 6c 69 6b 65 20 61 20 70 69 6e 67 2e 0a 3b 3b like a ping..;;
3570: 20 44 65 70 72 65 63 61 74 65 64 20 66 6f 72 20 Deprecated for
3580: 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 2e 0a nmsg-transport..
3590: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;;.(define (rmt:
35a0: 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c login-no-auto-cl
35b0: 69 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e 6e 65 ient-setup conne
35c0: 63 74 69 6f 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 ction-info run-i
35d0: 64 29 0a 20 20 28 63 61 73 65 20 2a 74 72 61 6e d). (case *tran
35e0: 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 20 sport-type*.
35f0: 28 28 68 74 74 70 29 28 72 6d 74 3a 73 65 6e 64 ((http)(rmt:send
3600: 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 6f -receive-no-auto
3610: 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f -client-setup co
3620: 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c nnection-info 'l
3630: 6f 67 69 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 ogin run-id (lis
3640: 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 t *toppath* mega
3650: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 72 75 6e test-version run
3660: 2d 69 64 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 -id *my-client-s
3670: 69 67 6e 61 74 75 72 65 2a 29 29 29 0a 20 20 20 ignature*))).
3680: 20 3b 3b 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d ;;((nmsg)(nmsg-
3690: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
36a0: 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 -api-send-receiv
36b0: 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 e run-id connect
36c0: 69 6f 6e 2d 69 6e 66 6f 20 27 6c 6f 67 69 6e 20 ion-info 'login
36d0: 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 (list *toppath*
36e0: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
36f0: 20 72 75 6e 2d 69 64 20 2a 6d 79 2d 63 6c 69 65 run-id *my-clie
3700: 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 29 nt-signature*)))
3710: 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 68 61 6e 64 . ))..;; hand
3720: 20 6f 66 66 20 61 20 63 61 6c 6c 20 74 6f 20 6f off a call to o
3730: 6e 65 20 6f 66 20 74 68 65 20 64 62 3a 71 75 65 ne of the db:que
3740: 72 69 65 73 20 73 74 61 74 65 6d 65 6e 74 73 0a ries statements.
3750: 3b 3b 20 61 64 64 65 64 20 72 75 6e 2d 69 64 20 ;; added run-id
3760: 74 6f 20 6d 61 6b 65 20 6c 6f 6f 6b 69 6e 67 20 to make looking
3770: 75 70 20 74 68 65 20 63 6f 72 72 65 63 74 20 64 up the correct d
3780: 62 20 70 6f 73 73 69 62 6c 65 20 0a 3b 3b 0a 28 b possible .;;.(
3790: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 6e 65 define (rmt:gene
37a0: 72 61 6c 2d 63 61 6c 6c 20 73 74 6d 74 6e 61 6d ral-call stmtnam
37b0: 65 20 72 75 6e 2d 69 64 20 2e 20 70 61 72 61 6d e run-id . param
37c0: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
37d0: 65 63 65 69 76 65 20 27 67 65 6e 65 72 61 6c 2d eceive 'general-
37e0: 63 61 6c 6c 20 72 75 6e 2d 69 64 20 28 61 70 70 call run-id (app
37f0: 65 6e 64 20 28 6c 69 73 74 20 73 74 6d 74 6e 61 end (list stmtna
3800: 6d 65 20 72 75 6e 2d 69 64 29 20 70 61 72 61 6d me run-id) param
3810: 73 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 s)))..;; (define
3820: 20 28 72 6d 74 3a 73 79 6e 63 2d 69 6e 6d 65 6d (rmt:sync-inmem
3830: 2d 3e 64 62 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 ->db run-id).;;
3840: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
3850: 69 76 65 20 27 73 79 6e 63 2d 69 6e 6d 65 6d 2d ive 'sync-inmem-
3860: 3e 64 62 20 72 75 6e 2d 69 64 20 27 28 29 29 29 >db run-id '()))
3870: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 ..(define (rmt:s
3880: 64 62 2d 71 72 79 20 71 72 79 20 76 61 6c 20 72 db-qry qry val r
3890: 75 6e 2d 69 64 29 0a 20 20 3b 3b 20 61 64 64 20 un-id). ;; add
38a0: 63 61 63 68 69 6e 67 20 69 66 20 71 72 79 20 69 caching if qry i
38b0: 73 20 27 67 65 74 69 64 20 6f 72 20 27 67 65 74 s 'getid or 'get
38c0: 73 74 72 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d str. (rmt:send-
38d0: 72 65 63 65 69 76 65 20 27 73 64 62 2d 71 72 79 receive 'sdb-qry
38e0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 71 72 run-id (list qr
38f0: 79 20 76 61 6c 29 29 29 0a 0a 3b 3b 20 4e 4f 54 y val)))..;; NOT
3900: 20 43 4f 4d 50 4c 45 54 45 44 0a 28 64 65 66 69 COMPLETED.(defi
3910: 6e 65 20 28 72 6d 74 3a 72 75 6e 74 65 73 74 73 ne (rmt:runtests
3920: 20 75 73 65 72 20 72 75 6e 2d 69 64 20 74 65 73 user run-id tes
3930: 74 70 61 74 74 20 70 61 72 61 6d 73 29 0a 20 20 tpatt params).
3940: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
3950: 65 20 27 72 75 6e 74 65 73 74 73 20 72 75 6e 2d e 'runtests run-
3960: 69 64 20 74 65 73 74 70 61 74 74 29 29 0a 0a 3b id testpatt))..;
3970: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39b0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4b 20 45 20 =======.;; K E
39c0: 59 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d Y S .;;=========
39d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
3a10: 3b 20 54 68 65 73 65 20 72 65 71 75 69 72 65 20 ; These require
3a20: 72 75 6e 2d 69 64 20 62 65 63 61 75 73 65 20 74 run-id because t
3a30: 68 65 20 76 61 6c 75 65 73 20 63 6f 6d 65 20 66 he values come f
3a40: 72 6f 6d 20 74 68 65 20 72 75 6e 21 0a 3b 3b 0a rom the run!.;;.
3a50: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
3a60: 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 -key-val-pairs r
3a70: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
3a80: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
3a90: 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 key-val-pairs ru
3aa0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
3ab0: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
3ac0: 6d 74 3a 67 65 74 2d 6b 65 79 73 29 0a 20 20 28 mt:get-keys). (
3ad0: 69 66 20 2a 64 62 2d 6b 65 79 73 2a 20 2a 64 62 if *db-keys* *db
3ae0: 2d 6b 65 79 73 2a 20 0a 20 20 20 20 20 28 6c 65 -keys* . (le
3af0: 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e t ((res (rmt:sen
3b00: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b d-receive 'get-k
3b10: 65 79 73 20 23 66 20 27 28 29 29 29 29 0a 20 20 eys #f '()))).
3b20: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6b (set! *db-k
3b30: 65 79 73 2a 20 72 65 73 29 0a 20 20 20 20 20 20 eys* res).
3b40: 20 72 65 73 29 29 29 0a 0a 3b 3b 20 77 65 20 64 res)))..;; we d
3b50: 6f 6e 27 74 20 72 65 75 73 65 20 72 75 6e 2d 69 on't reuse run-i
3b60: 64 27 73 20 28 65 78 63 65 70 74 20 70 6f 73 73 d's (except poss
3b70: 69 62 6c 79 20 2a 61 66 74 65 72 2a 20 61 20 64 ibly *after* a d
3b80: 62 20 63 6c 65 61 6e 75 70 29 20 73 6f 20 69 74 b cleanup) so it
3b90: 20 69 73 20 73 61 66 65 0a 3b 3b 20 74 6f 20 63 is safe.;; to c
3ba0: 61 63 68 65 20 74 68 65 20 72 65 73 75 6c 73 20 ache the resuls
3bb0: 69 6e 20 61 20 68 61 73 68 0a 3b 3b 0a 28 64 65 in a hash.;;.(de
3bc0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 fine (rmt:get-ke
3bd0: 79 2d 76 61 6c 73 20 72 75 6e 2d 69 64 29 0a 20 y-vals run-id).
3be0: 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 (or (hash-table
3bf0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 6b 65 -ref/default *ke
3c00: 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 23 66 yvals* run-id #f
3c10: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 ). (let ((r
3c20: 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 es (rmt:send-rec
3c30: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 eive 'get-key-va
3c40: 6c 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d ls #f (list run-
3c50: 69 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 id)))). (
3c60: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
3c70: 2a 6b 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 *keyvals* run-id
3c80: 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 65 res). re
3c90: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 s)))..(define (r
3ca0: 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 73 29 0a mt:get-targets).
3cb0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
3cc0: 69 76 65 20 27 67 65 74 2d 74 61 72 67 65 74 73 ive 'get-targets
3cd0: 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 #f '()))..(defi
3ce0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 61 72 67 ne (rmt:get-targ
3cf0: 65 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d et run-id). (rm
3d00: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
3d10: 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d 69 get-target run-i
3d20: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 d (list run-id))
3d30: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
3d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
3d80: 54 20 45 20 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d T E S T S.;;====
3d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3dd0: 3d 3d 0a 0a 3b 3b 20 4a 75 73 74 20 73 6f 6d 65 ==..;; Just some
3de0: 20 73 79 6e 74 61 74 69 63 20 73 75 67 61 72 0a syntatic sugar.
3df0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 67 (define (rmt:reg
3e00: 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 ister-test run-i
3e10: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
3e20: 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a 67 65 -path). (rmt:ge
3e30: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 neral-call 'regi
3e40: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
3e50: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
3e60: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 0a 28 e item-path))..(
3e70: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
3e80: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
3e90: 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 estname item-pat
3ea0: 68 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 h). (rmt:send-r
3eb0: 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 eceive 'get-test
3ec0: 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 -id run-id (list
3ed0: 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 run-id testname
3ee0: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 item-path)))..(
3ef0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
3f00: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
3f10: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
3f20: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 (if (and (numb
3f30: 65 72 3f 20 72 75 6e 2d 69 64 29 28 6e 75 6d 62 er? run-id)(numb
3f40: 65 72 3f 20 74 65 73 74 2d 69 64 29 29 0a 20 20 er? test-id)).
3f50: 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 (rmt:send-re
3f60: 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 2d ceive 'get-test-
3f70: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
3f80: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
3f90: 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 est-id)). (
3fa0: 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 begin..(debug:pr
3fb0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
3fc0: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
3fd0: 47 3a 20 42 61 64 20 64 61 74 61 20 68 61 6e 64 G: Bad data hand
3fe0: 65 64 20 74 6f 20 72 6d 74 3a 67 65 74 2d 74 65 ed to rmt:get-te
3ff0: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 st-info-by-id ru
4000: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c n-id=" run-id ",
4010: 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d test-id=" test-
4020: 69 64 29 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c id)..(print-call
4030: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
4040: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 23 66 error-port))..#f
4050: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
4060: 74 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 t:test-get-rundi
4070: 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 r-from-test-id r
4080: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 un-id test-id).
4090: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
40a0: 76 65 20 27 74 65 73 74 2d 67 65 74 2d 72 75 6e ve 'test-get-run
40b0: 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 dir-from-test-id
40c0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
40d0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a n-id test-id))).
40e0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6f 70 .(define (rmt:op
40f0: 65 6e 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 en-test-db-by-te
4100: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
4110: 74 2d 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b t-id #!key (work
4120: 2d 61 72 65 61 20 23 66 29 29 0a 20 20 28 6c 65 -area #f)). (le
4130: 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 28 t* ((test-path (
4140: 69 66 20 28 73 74 72 69 6e 67 3f 20 77 6f 72 6b if (string? work
4150: 2d 61 72 65 61 29 0a 09 09 09 77 6f 72 6b 2d 61 -area)....work-a
4160: 72 65 61 0a 09 09 09 28 72 6d 74 3a 74 65 73 74 rea....(rmt:test
4170: 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d -get-rundir-from
4180: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
4190: 74 65 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 test-id)))).
41a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 2a (debug:print 3 *
41b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
41c0: 2a 20 22 54 45 53 54 20 50 41 54 48 3a 20 22 20 * "TEST PATH: "
41d0: 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 28 test-path). (
41e0: 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 74 65 73 open-test-db tes
41f0: 74 2d 70 61 74 68 29 29 29 0a 0a 3b 3b 20 57 41 t-path)))..;; WA
4200: 52 4e 49 4e 47 3a 20 54 68 69 73 20 63 75 72 72 RNING: This curr
4210: 65 6e 74 6c 79 20 62 79 70 61 73 73 65 73 20 74 ently bypasses t
4220: 68 65 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 77 he transaction w
4230: 72 61 70 70 65 64 20 77 72 69 74 65 73 20 73 79 rapped writes sy
4240: 73 74 65 6d 0a 28 64 65 66 69 6e 65 20 28 72 6d stem.(define (rm
4250: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
4260: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
4270: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 n-id test-id new
4280: 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 state newstatus
4290: 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 72 newcomment). (r
42a0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
42b0: 27 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 'test-set-state-
42c0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
42d0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
42e0: 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 test-id newstat
42f0: 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 e newstatus newc
4300: 6f 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 omment)))..(defi
4310: 6e 65 20 28 72 6d 74 3a 73 65 74 2d 74 65 73 74 ne (rmt:set-test
4320: 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 s-state-status r
4330: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 20 un-id testnames
4340: 63 75 72 72 73 74 61 74 65 20 63 75 72 72 73 74 currstate currst
4350: 61 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 atus newstate ne
4360: 77 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 3a wstatus). (rmt:
4370: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 send-receive 'se
4380: 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 t-tests-state-st
4390: 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 atus run-id (lis
43a0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d t run-id testnam
43b0: 65 73 20 63 75 72 72 73 74 61 74 65 20 63 75 72 es currstate cur
43c0: 72 73 74 61 74 75 73 20 6e 65 77 73 74 61 74 65 rstatus newstate
43d0: 20 6e 65 77 73 74 61 74 75 73 29 29 29 0a 0a 28 newstatus)))..(
43e0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
43f0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 tests-for-run ru
4400: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 n-id testpatt st
4410: 61 74 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 ates statuses of
4420: 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 fset limit not-i
4430: 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f n sort-by sort-o
4440: 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 rder qryvals las
4450: 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 0a 20 t-update mode).
4460: 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 75 (if (number? ru
4470: 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 n-id). (rmt
4480: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
4490: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
44a0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
44b0: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 n-id testpatt st
44c0: 61 74 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 ates statuses of
44d0: 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 fset limit not-i
44e0: 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f n sort-by sort-o
44f0: 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 rder qryvals las
4500: 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 29 0a t-update mode)).
4510: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 (begin..(d
4520: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
4530: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4540: 70 6f 72 74 2a 20 22 72 6d 74 3a 67 65 74 2d 74 port* "rmt:get-t
4550: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 63 61 6c ests-for-run cal
4560: 6c 65 64 20 77 69 74 68 20 62 61 64 20 72 75 6e led with bad run
4570: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 28 -id=" run-id)..(
4580: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
4590: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
45a0: 70 6f 72 74 29 29 0a 09 27 28 29 29 29 29 0a 0a port))..'())))..
45b0: 3b 3b 20 67 65 74 20 73 74 75 66 66 20 76 69 61 ;; get stuff via
45c0: 20 73 79 6e 63 68 61 73 68 20 0a 28 64 65 66 69 synchash .(defi
45d0: 6e 65 20 28 72 6d 74 3a 73 79 6e 63 68 61 73 68 ne (rmt:synchash
45e0: 2d 67 65 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 -get run-id proc
45f0: 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 synckey keynum
4600: 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 params). (rmt:s
4610: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 79 6e end-receive 'syn
4620: 63 68 61 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 chash-get run-id
4630: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 70 72 (list run-id pr
4640: 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 oc synckey keynu
4650: 6d 20 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 m params)))..;;
4660: 49 44 45 41 3a 20 54 68 72 65 61 64 69 66 79 20 IDEA: Threadify
4670: 74 68 65 73 65 20 2d 20 74 68 65 79 20 73 70 65 these - they spe
4680: 6e 64 20 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 nd a lot of time
4690: 20 77 61 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a waiting ....;;.
46a0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
46b0: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d -tests-for-runs-
46c0: 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 mindata run-ids
46d0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
46e0: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 status not-in).
46f0: 20 28 6c 65 74 20 28 28 6d 75 6c 74 69 2d 72 75 (let ((multi-ru
4700: 6e 2d 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 n-mutex (make-mu
4710: 74 65 78 29 29 0a 09 28 72 75 6e 2d 69 64 2d 6c tex))..(run-id-l
4720: 69 73 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a ist (if run-ids.
4730: 09 09 09 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 ... run-ids....
4740: 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e (rmt:get-all-run
4750: 2d 69 64 73 29 29 29 0a 09 28 72 65 73 75 6c 74 -ids)))..(result
4760: 20 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 '())).
4770: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 (if (null? run-i
4780: 64 2d 6c 69 73 74 29 0a 09 27 28 29 0a 09 28 6c d-list)..'()..(l
4790: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 et loop ((hed
47a0: 20 20 28 63 61 72 20 72 75 6e 2d 69 64 2d 6c 69 (car run-id-li
47b0: 73 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 st))... (tal
47c0: 20 20 20 28 63 64 72 20 72 75 6e 2d 69 64 2d 6c (cdr run-id-l
47d0: 69 73 74 29 29 0a 09 09 20 20 20 28 74 68 72 65 ist))... (thre
47e0: 61 64 73 20 27 28 29 29 29 0a 09 20 20 28 69 66 ads '())).. (if
47f0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 74 68 72 65 (> (length thre
4800: 61 64 73 29 20 35 29 0a 09 20 20 20 20 20 20 28 ads) 5).. (
4810: 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 28 66 69 loop hed tal (fi
4820: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 68 lter (lambda (th
4830: 29 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 )(not (member (t
4840: 68 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 hread-state th)
4850: 27 28 74 65 72 6d 69 6e 61 74 65 64 20 64 65 61 '(terminated dea
4860: 64 29 29 29 29 20 74 68 72 65 61 64 73 29 29 0a d)))) threads)).
4870: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e . (let* ((n
4880: 65 77 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 ewthread (make-t
4890: 68 72 65 61 64 0a 09 09 09 09 20 28 6c 61 6d 62 hread..... (lamb
48a0: 64 61 20 28 29 0a 09 09 09 09 20 20 20 28 6c 65 da ()..... (le
48b0: 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e t ((res (rmt:sen
48c0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
48d0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e ests-for-run-min
48e0: 64 61 74 61 20 68 65 64 20 28 6c 69 73 74 20 68 data hed (list h
48f0: 65 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 ed testpatt stat
4900: 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e es status not-in
4910: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 69 ))))..... (i
4920: 66 20 28 6c 69 73 74 3f 20 72 65 73 29 0a 09 09 f (list? res)...
4930: 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 09 ... (begin......
4940: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
4950: 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 multi-run-mutex)
4960: 0a 09 09 09 09 09 20 20 20 28 73 65 74 21 20 72 ...... (set! r
4970: 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 esult (append re
4980: 73 75 6c 74 20 72 65 73 29 29 0a 09 09 09 09 09 sult res))......
4990: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
49a0: 21 20 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 ! multi-run-mute
49b0: 78 29 29 0a 09 09 09 09 09 20 28 64 65 62 75 67 x))...... (debug
49c0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
49d0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
49e0: 2a 20 22 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 * "get-tests-for
49f0: 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 66 61 69 -run-mindata fai
4a00: 6c 65 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 led for run-id "
4a10: 20 68 65 64 20 22 2c 20 74 65 73 74 70 61 74 74 hed ", testpatt
4a20: 20 22 20 74 65 73 74 70 61 74 74 20 22 2c 20 73 " testpatt ", s
4a30: 74 61 74 65 73 20 22 20 73 74 61 74 65 73 20 22 tates " states "
4a40: 2c 20 73 74 61 74 75 73 20 22 20 73 74 61 74 75 , status " statu
4a50: 73 20 22 2c 20 6e 6f 74 2d 69 6e 20 22 20 6e 6f s ", not-in " no
4a60: 74 2d 69 6e 29 29 29 29 0a 09 09 09 09 20 28 63 t-in))))..... (c
4a70: 6f 6e 63 20 22 6d 75 6c 74 69 2d 72 75 6e 2d 74 onc "multi-run-t
4a80: 68 72 65 61 64 20 66 6f 72 20 72 75 6e 2d 69 64 hread for run-id
4a90: 20 22 20 68 65 64 29 29 29 0a 09 09 20 20 20 20 " hed)))...
4aa0: 20 28 6e 65 77 74 68 72 65 61 64 73 20 28 63 6f (newthreads (co
4ab0: 6e 73 20 6e 65 77 74 68 72 65 61 64 20 74 68 72 ns newthread thr
4ac0: 65 61 64 73 29 29 29 0a 09 09 28 74 68 72 65 61 eads)))...(threa
4ad0: 64 2d 73 74 61 72 74 21 20 6e 65 77 74 68 72 65 d-start! newthre
4ae0: 61 64 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c ad)...(thread-sl
4af0: 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 67 69 eep! 0.05) ;; gi
4b00: 76 65 20 74 68 61 74 20 74 68 72 65 61 64 20 73 ve that thread s
4b10: 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 ome time to star
4b20: 74 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 t...(if (null? t
4b30: 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 74 68 72 al)... newthr
4b40: 65 61 64 73 0a 09 09 20 20 20 20 28 6c 6f 6f 70 eads... (loop
4b50: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
4b60: 61 6c 29 20 6e 65 77 74 68 72 65 61 64 73 29 29 al) newthreads))
4b70: 29 29 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 )))). result)
4b80: 29 0a 0a 3b 3b 20 3b 3b 20 49 44 45 41 3a 20 54 )..;; ;; IDEA: T
4b90: 68 72 65 61 64 69 66 79 20 74 68 65 73 65 20 2d hreadify these -
4ba0: 20 74 68 65 79 20 73 70 65 6e 64 20 61 20 6c 6f they spend a lo
4bb0: 74 20 6f 66 20 74 69 6d 65 20 77 61 69 74 69 6e t of time waitin
4bc0: 67 20 2e 2e 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 g ....;; ;;.;; (
4bd0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
4be0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d tests-for-runs-m
4bf0: 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 74 indata run-ids t
4c00: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
4c10: 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 3b 3b tatus not-in).;;
4c20: 20 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 (let ((run-id
4c30: 2d 6c 69 73 74 20 28 69 66 20 72 75 6e 2d 69 64 -list (if run-id
4c40: 73 0a 3b 3b 20 09 09 09 20 72 75 6e 2d 69 64 73 s.;; ... run-ids
4c50: 0a 3b 3b 20 09 09 09 20 28 72 6d 74 3a 67 65 74 .;; ... (rmt:get
4c60: 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 29 -all-run-ids))))
4c70: 0a 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 20 61 .;; (apply a
4c80: 70 70 65 6e 64 20 28 6d 61 70 20 28 6c 61 6d 62 ppend (map (lamb
4c90: 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 da (run-id).;; .
4ca0: 09 09 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 .. (rmt:send-rec
4cb0: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d eive 'get-tests-
4cc0: 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 for-run-mindata
4cd0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
4ce0: 2d 69 64 73 20 74 65 73 74 70 61 74 74 20 73 74 -ids testpatt st
4cf0: 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d ates status not-
4d00: 69 6e 29 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 in))).;; ..
4d10: 20 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 29 run-id-list)))
4d20: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
4d30: 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f delete-test-reco
4d40: 72 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d rds run-id test-
4d50: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
4d60: 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d receive 'delete-
4d70: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 75 6e test-records run
4d80: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
4d90: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 3b 3b 20 test-id)))..;;
4da0: 54 68 69 73 20 69 73 20 6e 6f 74 20 6e 65 65 64 This is not need
4db0: 65 64 20 61 73 20 74 65 73 74 20 73 74 65 70 73 ed as test steps
4dc0: 20 61 72 65 20 64 65 6c 65 74 65 64 20 6f 6e 20 are deleted on
4dd0: 74 65 73 74 20 64 65 6c 65 74 65 20 63 61 6c 6c test delete call
4de0: 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 .;;.;; (define (
4df0: 72 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d rmt:delete-test-
4e00: 73 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 6e step-records run
4e10: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 3b 3b 20 -id test-id).;;
4e20: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
4e30: 69 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 74 ive 'delete-test
4e40: 2d 73 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 -step-records ru
4e50: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
4e60: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 d test-id)))..(d
4e70: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
4e80: 73 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 set-status-state
4e90: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4ea0: 73 74 61 74 75 73 20 73 74 61 74 65 20 6d 73 67 status state msg
4eb0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
4ec0: 63 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d ceive 'test-set-
4ed0: 73 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 6e status-state run
4ee0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
4ef0: 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 20 test-id status
4f00: 73 74 61 74 65 20 6d 73 67 29 29 29 0a 0a 28 64 state msg)))..(d
4f10: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
4f20: 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 toplevel-num-ite
4f30: 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ms run-id test-n
4f40: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
4f50: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 74 -receive 'test-t
4f60: 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d oplevel-num-item
4f70: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
4f80: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
4f90: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
4fa0: 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 rmt:get-previous
4fb0: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
4fc0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
4fd0: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 e item-path).;;
4fe0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
4ff0: 69 76 65 20 27 67 65 74 2d 70 72 65 76 69 6f 75 ive 'get-previou
5000: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
5010: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
5020: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
5030: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 item-path)))..(d
5040: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d efine (rmt:get-m
5050: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
5060: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
5070: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
5080: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 me item-path).
5090: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
50a0: 65 20 27 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d e 'get-matching-
50b0: 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 previous-test-ru
50c0: 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 n-records run-id
50d0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
50e0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
50f0: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 h)))..(define (r
5100: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 mt:test-get-logf
5110: 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 ile-info run-id
5120: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d test-name). (rm
5130: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5140: 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 test-get-logfile
5150: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c 69 -info run-id (li
5160: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e st run-id test-n
5170: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
5180: 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 (rmt:test-get-re
5190: 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d cords-for-index-
51a0: 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 file run-id test
51b0: 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 -name). (rmt:se
51c0: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
51d0: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
51e0: 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d -index-file run-
51f0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
5200: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 test-name)))..(d
5210: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
5220: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
5230: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
5240: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
5250: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
5260: 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 stinfo-state-sta
5270: 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 tus run-id (list
5280: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
5290: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
52a0: 3a 74 65 73 74 2d 73 65 74 2d 6c 6f 67 21 20 72 :test-set-log! r
52b0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6c 6f un-id test-id lo
52c0: 67 66 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e gf). (if (strin
52d0: 67 3f 20 6c 6f 67 66 29 28 72 6d 74 3a 67 65 6e g? logf)(rmt:gen
52e0: 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 2d eral-call 'test-
52f0: 73 65 74 2d 6c 6f 67 20 72 75 6e 2d 69 64 20 6c set-log run-id l
5300: 6f 67 66 20 74 65 73 74 2d 69 64 29 29 29 0a 0a ogf test-id)))..
5310: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
5320: 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-set-top-proces
5330: 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 65 73 s-pid run-id tes
5340: 74 2d 69 64 20 70 69 64 29 0a 20 20 28 72 6d 74 t-id pid). (rmt
5350: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
5360: 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 est-set-top-proc
5370: 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 28 ess-pid run-id (
5380: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
5390: 2d 69 64 20 70 69 64 29 29 29 0a 0a 28 64 65 66 -id pid)))..(def
53a0: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 ine (rmt:test-ge
53b0: 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 t-top-process-pi
53c0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
53d0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
53e0: 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d ceive 'test-get-
53f0: 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 top-process-pid
5400: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
5410: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a -id test-id)))..
5420: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
5430: 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e -run-ids-matchin
5440: 67 2d 74 61 72 67 65 74 20 6b 65 79 6e 61 6d 65 g-target keyname
5450: 73 20 74 61 72 67 65 74 20 72 65 73 20 72 75 6e s target res run
5460: 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 name testpatt st
5470: 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 atepatt statuspa
5480: 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d tt). (rmt:send-
5490: 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e receive 'get-run
54a0: 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 -ids-matching-ta
54b0: 72 67 65 74 20 23 66 20 28 6c 69 73 74 20 6b 65 rget #f (list ke
54c0: 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 ynames target re
54d0: 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 s runname testpa
54e0: 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 61 tt statepatt sta
54f0: 74 75 73 70 61 74 74 29 29 29 0a 0a 3b 3b 20 4e tuspatt)))..;; N
5500: 4f 54 45 3a 20 54 68 69 73 20 77 69 6c 6c 20 6f OTE: This will o
5510: 70 65 6e 20 61 6e 64 20 61 63 63 65 73 73 20 41 pen and access A
5520: 4c 4c 20 72 75 6e 20 64 61 74 61 62 61 73 65 73 LL run databases
5530: 2e 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 . .;;.(define (r
5540: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 68 mt:test-get-path
5550: 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 s-matching-keyna
5560: 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b mes-target-new k
5570: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
5580: 65 73 20 74 65 73 74 70 61 74 74 20 73 74 61 74 es testpatt stat
5590: 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 74 epatt statuspatt
55a0: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 runname). (let
55b0: 20 28 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a ((run-ids (rmt:
55c0: 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 get-run-ids-matc
55d0: 68 69 6e 67 2d 74 61 72 67 65 74 20 6b 65 79 6e hing-target keyn
55e0: 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 20 ames target res
55f0: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
5600: 20 73 74 61 74 65 70 61 74 74 20 73 74 61 74 75 statepatt statu
5610: 73 70 61 74 74 29 29 29 0a 20 20 20 20 28 61 70 spatt))). (ap
5620: 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 20 ply append ..
5630: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 (map (lambda (ru
5640: 6e 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a 73 n-id)... (rmt:s
5650: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
5660: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
5670: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
5680: 72 67 65 74 2d 6e 65 77 20 72 75 6e 2d 69 64 20 rget-new run-id
5690: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6b 65 79 (list run-id key
56a0: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
56b0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 testpatt statep
56c0: 61 74 74 20 73 74 61 74 75 73 70 61 74 74 20 72 att statuspatt r
56d0: 75 6e 6e 61 6d 65 29 29 29 0a 09 20 20 20 72 75 unname))).. ru
56e0: 6e 2d 69 64 73 29 29 29 29 0a 0a 3b 3b 20 28 64 n-ids))))..;; (d
56f0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
5700: 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 20 un-ids-matching
5710: 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 keynames target
5720: 72 65 73 29 0a 3b 3b 20 20 20 28 72 6d 74 3a 73 res).;; (rmt:s
5730: 65 6e 64 2d 72 65 63 65 69 76 65 20 23 66 20 27 end-receive #f '
5740: 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 get-run-ids-matc
5750: 68 69 6e 67 20 28 6c 69 73 74 20 6b 65 79 6e 61 hing (list keyna
5760: 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 29 29 mes target res))
5770: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
5780: 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d get-prereqs-not-
5790: 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f met run-id waito
57a0: 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e 61 6d 65 ns ref-test-name
57b0: 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 ref-item-path #
57c0: 21 6b 65 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 !key (mode '(nor
57d0: 6d 61 6c 29 29 28 69 74 65 6d 6d 61 70 73 20 23 mal))(itemmaps #
57e0: 66 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d f)). (rmt:send-
57f0: 72 65 63 65 69 76 65 20 27 67 65 74 2d 70 72 65 receive 'get-pre
5800: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e reqs-not-met run
5810: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
5820: 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 74 65 73 waitons ref-tes
5830: 74 2d 6e 61 6d 65 20 72 65 66 2d 69 74 65 6d 2d t-name ref-item-
5840: 70 61 74 68 20 6d 6f 64 65 20 69 74 65 6d 6d 61 path mode itemma
5850: 70 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ps)))..(define (
5860: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
5870: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
5880: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 0a 20 run-id run-id).
5890: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
58a0: 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 ve 'get-count-te
58b0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
58c0: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c run-id run-id (l
58d0: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b ist run-id)))..;
58e0: 3b 20 53 74 61 74 69 73 74 69 63 61 6c 20 71 75 ; Statistical qu
58f0: 65 72 69 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 eries..(define (
5900: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
5910: 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d sts-running run-
5920: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
5930: 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f 75 receive 'get-cou
5940: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
5950: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
5960: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
5970: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d (rmt:get-count-
5980: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f tests-running-fo
5990: 72 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 r-testname run-i
59a0: 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 d testname). (r
59b0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
59c0: 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 'get-count-tests
59d0: 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 -running-for-tes
59e0: 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 28 6c 69 tname run-id (li
59f0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 st run-id testna
5a00: 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 me)))..(define (
5a10: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
5a20: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
5a30: 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 6a obgroup run-id j
5a40: 6f 62 67 72 6f 75 70 29 0a 20 20 28 72 6d 74 3a obgroup). (rmt:
5a50: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5a60: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
5a70: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
5a80: 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 p run-id (list r
5a90: 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 29 29 un-id jobgroup))
5aa0: 29 0a 0a 3b 3b 20 73 74 61 74 65 20 61 6e 64 20 )..;; state and
5ab0: 73 74 61 74 75 73 20 61 72 65 20 65 78 74 72 61 status are extra
5ac0: 20 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 61 6c hints not usual
5ad0: 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 63 ly used in the c
5ae0: 61 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 64 alculation.;;.(d
5af0: 65 66 69 6e 65 20 28 72 6d 74 3a 72 6f 6c 6c 2d efine (rmt:roll-
5b00: 75 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 up-pass-fail-cou
5b10: 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nts run-id test-
5b20: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 name item-path s
5b30: 74 61 74 65 20 73 74 61 74 75 73 29 0a 20 20 28 tate status). (
5b40: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5b50: 20 27 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 'roll-up-pass-f
5b60: 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 ail-counts run-i
5b70: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
5b80: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
5b90: 74 68 20 73 74 61 74 65 20 73 74 61 74 75 73 29 th state status)
5ba0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5bb0: 3a 75 70 64 61 74 65 2d 70 61 73 73 2d 66 61 69 :update-pass-fai
5bc0: 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 l-counts run-id
5bd0: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d test-name). (rm
5be0: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
5bf0: 75 70 64 61 74 65 2d 70 61 73 73 2d 66 61 69 6c update-pass-fail
5c00: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
5c10: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
5c20: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 0a me test-name))..
5c30: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 6f 70 (define (rmt:top
5c40: 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 -test-set-per-pf
5c50: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
5c60: 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 est-name). (rmt
5c70: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
5c80: 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d op-test-set-per-
5c90: 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 pf-counts run-id
5ca0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
5cb0: 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 st-name)))..(def
5cc0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 61 77 ine (rmt:get-raw
5cd0: 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 -run-stats run-i
5ce0: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
5cf0: 65 63 65 69 76 65 20 27 67 65 74 2d 72 61 77 2d eceive 'get-raw-
5d00: 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 run-stats run-id
5d10: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
5d20: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
5d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 ==========.;; R
5d70: 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U N S.;;=======
5d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5dc0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
5dd0: 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 t-run-info run-i
5de0: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
5df0: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d eceive 'get-run-
5e00: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c 69 73 info run-id (lis
5e10: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
5e20: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6e 75 fine (rmt:get-nu
5e30: 6d 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 29 0a m-runs runpatt).
5e40: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5e50: 69 76 65 20 27 67 65 74 2d 6e 75 6d 2d 72 75 6e ive 'get-num-run
5e60: 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 70 61 s #f (list runpa
5e70: 74 74 29 29 29 0a 0a 3b 3b 20 55 73 65 20 74 68 tt)))..;; Use th
5e80: 65 20 73 70 65 63 69 61 6c 20 72 75 6e 2d 69 64 e special run-id
5e90: 20 3d 3d 20 23 66 20 73 63 65 6e 61 72 69 6f 20 == #f scenario
5ea0: 68 65 72 65 20 73 69 6e 63 65 20 74 68 65 72 65 here since there
5eb0: 20 69 73 20 6e 6f 20 72 75 6e 20 79 65 74 0a 28 is no run yet.(
5ec0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 67 69 define (rmt:regi
5ed0: 73 74 65 72 2d 72 75 6e 20 6b 65 79 76 61 6c 73 ster-run keyvals
5ee0: 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 runname state s
5ef0: 74 61 74 75 73 20 75 73 65 72 29 0a 20 20 28 72 tatus user). (r
5f00: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
5f10: 27 72 65 67 69 73 74 65 72 2d 72 75 6e 20 23 66 'register-run #f
5f20: 20 28 6c 69 73 74 20 6b 65 79 76 61 6c 73 20 72 (list keyvals r
5f30: 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 unname state sta
5f40: 74 75 73 20 75 73 65 72 29 29 29 0a 20 20 20 20 tus user))).
5f50: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
5f60: 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d t-run-name-from-
5f70: 69 64 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d id run-id). (rm
5f80: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5f90: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
5fa0: 6d 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 m-id run-id (lis
5fb0: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
5fc0: 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 fine (rmt:delete
5fd0: 2d 72 75 6e 20 72 75 6e 2d 69 64 29 0a 20 20 28 -run run-id). (
5fe0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5ff0: 20 27 64 65 6c 65 74 65 2d 72 75 6e 20 72 75 6e 'delete-run run
6000: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
6010: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
6020: 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 t:update-run-sta
6030: 74 73 20 72 75 6e 2d 69 64 20 73 74 61 74 73 29 ts run-id stats)
6040: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
6050: 65 69 76 65 20 27 75 70 64 61 74 65 2d 72 75 6e eive 'update-run
6060: 2d 73 74 61 74 73 20 23 66 20 28 6c 69 73 74 20 -stats #f (list
6070: 72 75 6e 2d 69 64 20 73 74 61 74 73 29 29 29 0a run-id stats))).
6080: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 .(define (rmt:de
6090: 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 lete-old-deleted
60a0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 -test-records).
60b0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
60c0: 76 65 20 27 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 ve 'delete-old-d
60d0: 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f eleted-test-reco
60e0: 72 64 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 rds #f '()))..(d
60f0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
6100: 75 6e 73 20 72 75 6e 70 61 74 74 20 63 6f 75 6e uns runpatt coun
6110: 74 20 6f 66 66 73 65 74 20 6b 65 79 70 61 74 74 t offset keypatt
6120: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
6130: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 73 eceive 'get-runs
6140: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 70 61 74 #f (list runpat
6150: 74 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 20 6b t count offset k
6160: 65 79 70 61 74 74 73 29 29 29 0a 0a 28 64 65 66 eypatts)))..(def
6170: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c ine (rmt:get-all
6180: 2d 72 75 6e 2d 69 64 73 29 0a 20 20 28 72 6d 74 -run-ids). (rmt
6190: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
61a0: 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 20 23 et-all-run-ids #
61b0: 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 f '()))..(define
61c0: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 2d 72 (rmt:get-prev-r
61d0: 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 29 0a 20 un-ids run-id).
61e0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
61f0: 76 65 20 27 67 65 74 2d 70 72 65 76 2d 72 75 6e ve 'get-prev-run
6200: 2d 69 64 73 20 23 66 20 28 6c 69 73 74 20 72 75 -ids #f (list ru
6210: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
6220: 20 28 72 6d 74 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 (rmt:lock/unloc
6230: 6b 2d 72 75 6e 20 72 75 6e 2d 69 64 20 6c 6f 63 k-run run-id loc
6240: 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 k unlock user).
6250: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6260: 76 65 20 27 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d ve 'lock/unlock-
6270: 72 75 6e 20 23 66 20 28 6c 69 73 74 20 72 75 6e run #f (list run
6280: 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 -id lock unlock
6290: 75 73 65 72 29 29 29 0a 0a 3b 3b 20 73 65 74 2f user)))..;; set/
62a0: 67 65 74 20 73 74 61 74 75 73 0a 28 64 65 66 69 get status.(defi
62b0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d ne (rmt:get-run-
62c0: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 29 0a 20 status run-id).
62d0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
62e0: 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 ve 'get-run-stat
62f0: 75 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d us #f (list run-
6300: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
6310: 72 6d 74 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 rmt:set-run-stat
6320: 75 73 20 72 75 6e 2d 69 64 20 72 75 6e 2d 73 74 us run-id run-st
6330: 61 74 75 73 20 23 21 6b 65 79 20 28 6d 73 67 20 atus #!key (msg
6340: 23 66 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 #f)). (rmt:send
6350: 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d 72 75 -receive 'set-ru
6360: 6e 2d 73 74 61 74 75 73 20 23 66 20 28 6c 69 73 n-status #f (lis
6370: 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 t run-id run-sta
6380: 74 75 73 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 tus msg)))..(def
6390: 69 6e 65 20 28 72 6d 74 3a 75 70 64 61 74 65 2d ine (rmt:update-
63a0: 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 72 run-event_time r
63b0: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
63c0: 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 nd-receive 'upda
63d0: 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d te-run-event_tim
63e0: 65 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 e #f (list run-i
63f0: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
6400: 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 mt:get-runs-by-p
6410: 61 74 74 20 20 6b 65 79 73 20 72 75 6e 6e 61 6d att keys runnam
6420: 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 6f epatt targpatt o
6430: 66 66 73 65 74 20 6c 69 6d 69 74 20 66 69 65 6c ffset limit fiel
6440: 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 70 64 ds last-runs-upd
6450: 61 74 65 29 20 3b 3b 20 66 69 65 6c 64 73 20 6f ate) ;; fields o
6460: 66 20 23 66 20 75 73 65 73 20 64 65 66 61 75 6c f #f uses defaul
6470: 74 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 t. (rmt:send-re
6480: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 73 2d ceive 'get-runs-
6490: 62 79 2d 70 61 74 74 20 23 66 20 28 6c 69 73 74 by-patt #f (list
64a0: 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 keys runnamepat
64b0: 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 t targpatt offse
64c0: 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 20 6c t limit fields l
64d0: 61 73 74 2d 72 75 6e 73 2d 75 70 64 61 74 65 29 ast-runs-update)
64e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
64f0: 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 :find-and-mark-i
6500: 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 ncomplete run-id
6510: 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 0a 20 ovr-deadtime).
6520: 20 28 69 66 20 28 72 6d 74 3a 73 65 6e 64 2d 72 (if (rmt:send-r
6530: 65 63 65 69 76 65 20 27 68 61 76 65 2d 69 6e 63 eceive 'have-inc
6540: 6f 6d 70 6c 65 74 65 73 3f 20 72 75 6e 2d 69 64 ompletes? run-id
6550: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6f 76 (list run-id ov
6560: 72 2d 64 65 61 64 74 69 6d 65 29 29 0a 20 20 20 r-deadtime)).
6570: 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (rmt:send-rec
6580: 65 69 76 65 20 27 6d 61 72 6b 2d 69 6e 63 6f 6d eive 'mark-incom
6590: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 28 6c 69 plete run-id (li
65a0: 73 74 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 st run-id ovr-de
65b0: 61 64 74 69 6d 65 29 29 29 29 0a 0a 28 64 65 66 adtime))))..(def
65c0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d 61 69 ine (rmt:get-mai
65d0: 6e 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d n-run-stats run-
65e0: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
65f0: 72 65 63 65 69 76 65 20 27 67 65 74 2d 6d 61 69 receive 'get-mai
6600: 6e 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 20 28 n-run-stats #f (
6610: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
6620: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
6630: 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 20 -var varname).
6640: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6650: 65 20 27 67 65 74 2d 76 61 72 20 23 66 20 28 6c e 'get-var #f (l
6660: 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 0a 0a ist varname)))..
6670: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 (define (rmt:set
6680: 2d 76 61 72 20 76 61 72 6e 61 6d 65 20 76 61 6c -var varname val
6690: 75 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ue). (rmt:send-
66a0: 72 65 63 65 69 76 65 20 27 73 65 74 2d 76 61 72 receive 'set-var
66b0: 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 6d #f (list varnam
66c0: 65 20 76 61 6c 75 65 29 29 29 0a 0a 3b 3b 3d 3d e value)))..;;==
66d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6710: 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4c 20 54 20 ====.;; M U L T
6720: 49 20 52 20 55 20 4e 20 20 20 51 20 55 20 45 20 I R U N Q U E
6730: 52 20 49 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d R I E S.;;======
6740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6780: 0a 0a 3b 3b 20 4e 65 65 64 20 74 6f 20 6d 6f 76 ..;; Need to mov
6790: 65 20 74 68 69 73 20 74 6f 20 6d 75 6c 74 69 2d e this to multi-
67a0: 72 75 6e 20 73 65 63 74 69 6f 6e 20 61 6e 64 20 run section and
67b0: 6d 61 6b 65 20 61 73 73 6f 63 69 61 74 65 64 20 make associated
67c0: 63 68 61 6e 67 65 73 0a 28 64 65 66 69 6e 65 20 changes.(define
67d0: 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 (rmt:find-and-ma
67e0: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 2d 61 6c rk-incomplete-al
67f0: 6c 2d 72 75 6e 73 20 23 21 6b 65 79 20 28 6f 76 l-runs #!key (ov
6800: 72 2d 64 65 61 64 74 69 6d 65 20 23 66 29 29 0a r-deadtime #f)).
6810: 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 73 (let ((run-ids
6820: 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 (rmt:get-all-ru
6830: 6e 2d 69 64 73 29 29 29 0a 20 20 20 20 28 66 6f n-ids))). (fo
6840: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
6850: 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 20 20 20 run-id)..
6860: 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 (rmt:find-and-ma
6870: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 rk-incomplete ru
6880: 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 6d n-id ovr-deadtim
6890: 65 29 29 0a 09 20 20 20 20 20 72 75 6e 2d 69 64 e)).. run-id
68a0: 73 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 s)))..;; get the
68b0: 20 70 72 65 76 69 6f 75 73 20 72 65 63 6f 72 64 previous record
68c0: 20 66 6f 72 20 77 68 65 6e 20 74 68 69 73 20 74 for when this t
68d0: 65 73 74 20 77 61 73 20 72 75 6e 20 77 68 65 72 est was run wher
68e0: 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 e all keys match
68f0: 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b 3b 20 but runname.;;
6900: 72 65 74 75 72 6e 73 20 23 66 20 69 66 20 6e 6f returns #f if no
6910: 20 73 75 63 68 20 74 65 73 74 20 66 6f 75 6e 64 such test found
6920: 2c 20 72 65 74 75 72 6e 73 20 61 20 73 69 6e 67 , returns a sing
6930: 6c 65 20 74 65 73 74 20 72 65 63 6f 72 64 20 69 le test record i
6940: 66 20 66 6f 75 6e 64 0a 3b 3b 20 0a 3b 3b 20 52 f found.;; .;; R
6950: 75 6e 20 74 68 69 73 20 61 74 20 74 68 65 20 63 un this at the c
6960: 6c 69 65 6e 74 20 65 6e 64 20 73 69 6e 63 65 20 lient end since
6970: 77 65 20 68 61 76 65 20 74 6f 20 63 6f 6e 6e 65 we have to conne
6980: 63 74 20 74 6f 20 6d 75 6c 74 69 70 6c 65 20 72 ct to multiple r
6990: 75 6e 2d 69 64 20 64 62 73 0a 3b 3b 0a 28 64 65 un-id dbs.;;.(de
69a0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 fine (rmt:get-pr
69b0: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
69c0: 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 65 record run-id te
69d0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
69e0: 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 h). (let* ((key
69f0: 76 61 6c 73 20 28 72 6d 74 3a 67 65 74 2d 6b 65 vals (rmt:get-ke
6a00: 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d y-val-pairs run-
6a10: 69 64 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 id)).. (keys
6a20: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a (rmt:get-keys)).
6a30: 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 69 . (selstr (stri
6a40: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 20 ng-intersperse
6a50: 6b 65 79 73 20 22 2c 22 29 29 0a 09 20 28 71 72 keys ",")).. (qr
6a60: 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e ystr (string-in
6a70: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
6a80: 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e 63 20 lambda (x)(conc
6a90: 78 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 22 x "=?")) keys) "
6aa0: 20 41 4e 44 20 22 29 29 29 0a 20 20 20 20 28 69 AND "))). (i
6ab0: 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c 73 29 0a f (not keyvals).
6ac0: 09 23 66 0a 09 28 6c 65 74 20 28 28 70 72 65 76 .#f..(let ((prev
6ad0: 2d 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 -run-ids (rmt:ge
6ae0: 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 72 t-prev-run-ids r
6af0: 75 6e 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 66 un-id))).. ;; f
6b00: 6f 72 20 65 61 63 68 20 72 75 6e 20 73 74 61 72 or each run star
6b10: 74 69 6e 67 20 77 69 74 68 20 74 68 65 20 6d 6f ting with the mo
6b20: 73 74 20 72 65 63 65 6e 74 20 6c 6f 6f 6b 20 74 st recent look t
6b30: 6f 20 73 65 65 20 69 66 20 74 68 65 72 65 20 69 o see if there i
6b40: 73 20 61 20 6d 61 74 63 68 69 6e 67 20 74 65 73 s a matching tes
6b50: 74 0a 09 20 20 3b 3b 20 69 66 20 66 6f 75 6e 64 t.. ;; if found
6b60: 20 74 68 65 6e 20 72 65 74 75 72 6e 20 74 68 61 then return tha
6b70: 74 20 6d 61 74 63 68 69 6e 67 20 74 65 73 74 20 t matching test
6b80: 72 65 63 6f 72 64 0a 09 20 20 28 64 65 62 75 67 record.. (debug
6b90: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
6ba0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 6c t-log-port* "sel
6bb0: 73 74 72 3a 20 22 20 73 65 6c 73 74 72 20 22 2c str: " selstr ",
6bc0: 20 71 72 79 73 74 72 3a 20 22 20 71 72 79 73 74 qrystr: " qryst
6bd0: 72 20 22 2c 20 6b 65 79 76 61 6c 73 3a 20 22 20 r ", keyvals: "
6be0: 6b 65 79 76 61 6c 73 20 22 2c 20 70 72 65 76 69 keyvals ", previ
6bf0: 6f 75 73 20 72 75 6e 20 69 64 73 20 66 6f 75 6e ous run ids foun
6c00: 64 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d 69 64 d: " prev-run-id
6c10: 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f s).. (if (null?
6c20: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 23 prev-run-ids) #
6c30: 66 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f f.. (let lo
6c40: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 70 72 op ((hed (car pr
6c50: 65 76 2d 72 75 6e 2d 69 64 73 29 29 0a 09 09 09 ev-run-ids))....
6c60: 20 28 74 61 6c 20 28 63 64 72 20 70 72 65 76 2d (tal (cdr prev-
6c70: 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 28 6c 65 run-ids)))...(le
6c80: 74 20 28 28 72 65 73 75 6c 74 73 20 28 72 6d 74 t ((results (rmt
6c90: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
6ca0: 75 6e 20 68 65 64 20 28 63 6f 6e 63 20 74 65 73 un hed (conc tes
6cb0: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
6cc0: 70 61 74 68 29 20 27 28 29 20 27 28 29 20 3b 3b path) '() '() ;;
6cd0: 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 run-id testpatt
6ce0: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 states statuses
6cf0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
6d00: 23 66 20 23 66 20 20 20 20 20 20 20 20 20 20 20 #f #f
6d10: 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 20 6c 69 ;; offset li
6d20: 6d 69 74 20 6e 6f 74 2d 69 6e 20 68 69 64 65 2f mit not-in hide/
6d30: 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 09 09 20 not-hide.......
6d40: 20 20 20 20 20 23 66 20 23 66 20 23 66 20 23 66 #f #f #f #f
6d50: 20 27 6e 6f 72 6d 61 6c 29 29 29 20 3b 3b 20 73 'normal))) ;; s
6d60: 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 ort-by sort-orde
6d70: 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 r qryvals last-u
6d80: 70 64 61 74 65 20 6d 6f 64 65 0a 09 09 20 20 28 pdate mode... (
6d90: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
6da0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6db0: 20 22 47 6f 74 20 74 65 73 74 73 20 66 6f 72 20 "Got tests for
6dc0: 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 run-id " run-id
6dd0: 22 2c 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 74 ", test-name " t
6de0: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d est-name ", item
6df0: 2d 70 61 74 68 20 22 20 69 74 65 6d 2d 70 61 74 -path " item-pat
6e00: 68 20 22 3a 20 22 20 72 65 73 75 6c 74 73 29 0a h ": " results).
6e10: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 .. (if (and (nu
6e20: 6c 6c 3f 20 72 65 73 75 6c 74 73 29 0a 09 09 09 ll? results)....
6e30: 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 (not (null? t
6e40: 61 6c 29 29 29 0a 09 09 20 20 20 20 20 20 28 6c al)))... (l
6e50: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
6e60: 72 20 74 61 6c 29 29 0a 09 09 20 20 20 20 20 20 r tal))...
6e70: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 73 75 6c (if (null? resul
6e80: 74 73 29 20 23 66 0a 09 09 09 20 20 28 63 61 72 ts) #f.... (car
6e90: 20 72 65 73 75 6c 74 73 29 29 29 29 29 29 29 29 results))))))))
6ea0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6eb0: 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 29 0a :get-run-stats).
6ec0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
6ed0: 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 ive 'get-run-sta
6ee0: 74 73 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b 3d ts #f '()))..;;=
6ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f30: 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 54 20 45 20 =====.;; S T E
6f40: 50 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d P S.;;==========
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
6f90: 20 47 65 74 74 69 6e 67 20 73 74 65 70 73 20 69 Getting steps i
6fa0: 73 20 6d 6f 72 65 20 63 6f 6d 70 6c 69 63 61 74 s more complicat
6fb0: 65 64 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 67 69 76 ed..;;.;; If giv
6fc0: 65 6e 20 77 6f 72 6b 20 61 72 65 61 20 0a 3b 3b en work area .;;
6fd0: 20 20 31 2e 20 46 69 6e 64 20 74 68 65 20 74 65 1. Find the te
6fe0: 73 74 64 61 74 2e 64 62 20 66 69 6c 65 0a 3b 3b stdat.db file.;;
6ff0: 20 20 32 2e 20 4f 70 65 6e 20 74 68 65 20 74 65 2. Open the te
7000: 73 74 64 61 74 2e 64 62 20 66 69 6c 65 20 61 6e stdat.db file an
7010: 64 20 64 6f 20 74 68 65 20 71 75 65 72 79 0a 3b d do the query.;
7020: 3b 20 49 66 20 6e 6f 74 20 67 69 76 65 6e 20 74 ; If not given t
7030: 68 65 20 77 6f 72 6b 20 61 72 65 61 0a 3b 3b 20 he work area.;;
7040: 20 31 2e 20 44 6f 20 61 20 72 65 6d 6f 74 65 20 1. Do a remote
7050: 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 68 65 20 call to get the
7060: 74 65 73 74 20 70 61 74 68 0a 3b 3b 20 20 32 2e test path.;; 2.
7070: 20 43 6f 6e 74 69 6e 75 65 20 61 73 20 61 62 6f Continue as abo
7080: 76 65 0a 3b 3b 20 0a 3b 3b 28 64 65 66 69 6e 65 ve.;; .;;(define
7090: 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d (rmt:get-steps-
70a0: 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 for-test run-id
70b0: 74 65 73 74 2d 69 64 29 0a 3b 3b 20 20 28 72 6d test-id).;; (rm
70c0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
70d0: 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 20 72 get-steps-data r
70e0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 74 un-id (list test
70f0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
7100: 28 72 6d 74 3a 74 65 73 74 73 74 65 70 2d 73 65 (rmt:teststep-se
7110: 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 t-status! run-id
7120: 20 74 65 73 74 2d 69 64 20 74 65 73 74 73 74 65 test-id testste
7130: 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d 69 6e 20 p-name state-in
7140: 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e status-in commen
7150: 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 28 6c 65 t logfile). (le
7160: 74 2a 20 28 28 73 74 61 74 65 20 20 20 20 20 28 t* ((state (
7170: 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c 69 items:check-vali
7180: 64 2d 69 74 65 6d 73 20 22 73 74 61 74 65 22 20 d-items "state"
7190: 73 74 61 74 65 2d 69 6e 29 29 0a 09 20 28 73 74 state-in)).. (st
71a0: 61 74 75 73 20 20 20 20 28 69 74 65 6d 73 3a 63 atus (items:c
71b0: 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 heck-valid-items
71c0: 20 22 73 74 61 74 75 73 22 20 73 74 61 74 75 73 "status" status
71d0: 2d 69 6e 29 29 29 0a 20 20 20 20 28 69 66 20 28 -in))). (if (
71e0: 6f 72 20 28 6e 6f 74 20 73 74 61 74 65 29 28 6e or (not state)(n
71f0: 6f 74 20 73 74 61 74 75 73 29 29 0a 09 28 64 65 ot status))..(de
7200: 62 75 67 3a 70 72 69 6e 74 20 33 20 2a 64 65 66 bug:print 3 *def
7210: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7220: 57 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c 69 64 WARNING: Invalid
7230: 20 22 20 28 69 66 20 73 74 61 74 75 73 20 22 73 " (if status "s
7240: 74 61 74 75 73 22 20 22 73 74 61 74 65 22 29 0a tatus" "state").
7250: 09 09 20 20 20 20 20 22 20 76 61 6c 75 65 20 5c .. " value \
7260: 22 22 20 28 69 66 20 73 74 61 74 75 73 20 73 74 "" (if status st
7270: 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e ate-in status-in
7280: 29 20 22 5c 22 2c 20 75 70 64 61 74 65 20 79 6f ) "\", update yo
7290: 75 72 20 76 61 6c 69 64 76 61 6c 75 65 73 20 73 ur validvalues s
72a0: 65 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 74 65 ection in megate
72b0: 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 20 20 st.config")).
72c0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
72d0: 76 65 20 27 74 65 73 74 73 74 65 70 2d 73 65 74 ve 'teststep-set
72e0: 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 -status! run-id
72f0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
7300: 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 t-id teststep-na
7310: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
7320: 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f us-in comment lo
7330: 67 66 69 6c 65 29 29 29 29 0a 0a 28 64 65 66 69 gfile))))..(defi
7340: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 ne (rmt:get-step
7350: 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 s-for-test run-i
7360: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d d test-id). (rm
7370: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7380: 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
7390: 73 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 st run-id (list
73a0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
73b0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
73c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
7400: 54 20 45 20 53 20 54 20 20 20 44 20 41 20 54 20 T E S T D A T
7410: 41 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d A .;;===========
7420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
7460: 66 69 6e 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 fine (rmt:read-t
7470: 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 est-data run-id
7480: 74 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 test-id category
7490: 70 61 74 74 20 23 21 6b 65 79 20 28 77 6f 72 6b patt #!key (work
74a0: 2d 61 72 65 61 20 23 66 29 29 20 0a 20 20 28 72 -area #f)) . (r
74b0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
74c0: 27 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 20 'read-test-data
74d0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
74e0: 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 65 -id test-id cate
74f0: 67 6f 72 79 70 61 74 74 29 29 29 0a 3b 3b 20 20 gorypatt))).;;
7500: 20 28 6c 65 74 20 28 28 74 64 62 20 20 28 72 6d (let ((tdb (rm
7510: 74 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 2d 62 t:open-test-db-b
7520: 79 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 y-test-id run-id
7530: 20 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 test-id work-ar
7540: 65 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 ea: work-area)))
7550: 0a 3b 3b 20 20 20 20 20 28 69 66 20 74 64 62 0a .;; (if tdb.
7560: 3b 3b 20 09 28 74 64 62 3a 72 65 61 64 2d 74 65 ;; .(tdb:read-te
7570: 73 74 2d 64 61 74 61 20 74 64 62 20 74 65 73 74 st-data tdb test
7580: 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 -id categorypatt
7590: 29 0a 3b 3b 20 09 27 28 29 29 29 29 0a 0a 28 64 ).;; .'())))..(d
75a0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d efine (rmt:testm
75b0: 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 74 eta-add-record t
75c0: 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a estname). (rmt:
75d0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
75e0: 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 stmeta-add-recor
75f0: 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 6e d #f (list testn
7600: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
7610: 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 (rmt:testmeta-ge
7620: 74 2d 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d t-record testnam
7630: 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 e). (rmt:send-r
7640: 65 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 eceive 'testmeta
7650: 2d 67 65 74 2d 72 65 63 6f 72 64 20 23 66 20 28 -get-record #f (
7660: 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 list testname)))
7670: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
7680: 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 estmeta-update-f
7690: 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 ield test-name f
76a0: 6c 64 20 76 61 6c 29 0a 20 20 28 72 6d 74 3a 73 ld val). (rmt:s
76b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
76c0: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
76d0: 6c 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 ld #f (list test
76e0: 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 -name fld val)))
76f0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
7700: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 est-data-rollup
7710: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
7720: 74 61 74 75 73 29 0a 20 20 28 72 6d 74 3a 73 65 tatus). (rmt:se
7730: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
7740: 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e -data-rollup run
7750: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7760: 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 29 test-id status)
7770: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7780: 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 :csv->test-data
7790: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 run-id test-id c
77a0: 73 76 64 61 74 61 29 0a 20 20 28 72 6d 74 3a 73 svdata). (rmt:s
77b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 63 73 76 end-receive 'csv
77c0: 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d ->test-data run-
77d0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
77e0: 74 65 73 74 2d 69 64 20 63 73 76 64 61 74 61 29 test-id csvdata)
77f0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
7800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
7840: 20 54 20 41 20 53 20 4b 20 53 0a 3b 3b 3d 3d 3d T A S K S.;;===
7850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7890: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ===..(define (rm
78a0: 74 3a 74 61 73 6b 73 2d 66 69 6e 64 2d 74 61 73 t:tasks-find-tas
78b0: 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 k-queue-records
78c0: 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 target run-name
78d0: 74 65 73 74 2d 70 61 74 74 20 73 74 61 74 65 2d test-patt state-
78e0: 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 patt action-patt
78f0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7900: 63 65 69 76 65 20 27 66 69 6e 64 2d 74 61 73 6b ceive 'find-task
7910: 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 23 -queue-records #
7920: 66 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 f (list target r
7930: 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 un-name test-pat
7940: 74 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 t state-patt act
7950: 69 6f 6e 2d 70 61 74 74 29 29 29 0a 0a 28 64 65 ion-patt)))..(de
7960: 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d fine (rmt:tasks-
7970: 61 64 64 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 add action owner
7980: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
7990: 74 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 29 testpatt params)
79a0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
79b0: 65 69 76 65 20 27 74 61 73 6b 73 2d 61 64 64 20 eive 'tasks-add
79c0: 23 66 20 28 6c 69 73 74 20 61 63 74 69 6f 6e 20 #f (list action
79d0: 6f 77 6e 65 72 20 74 61 72 67 65 74 20 72 75 6e owner target run
79e0: 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 70 61 name testpatt pa
79f0: 72 61 6d 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 rams)))..(define
7a00: 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 74 2d (rmt:tasks-set-
7a10: 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 state-given-para
7a20: 6d 2d 6b 65 79 20 70 61 72 61 6d 2d 6b 65 79 20 m-key param-key
7a30: 6e 65 77 2d 73 74 61 74 65 29 0a 20 20 28 72 6d new-state). (rm
7a40: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7a50: 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d tasks-set-state-
7a60: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
7a70: 23 66 20 28 6c 69 73 74 20 20 70 61 72 61 6d 2d #f (list param-
7a80: 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 29 29 29 key new-state)))
7a90: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
7aa0: 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 20 74 61 asks-get-last ta
7ab0: 72 67 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 rget runname).
7ac0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7ad0: 65 20 27 74 61 73 6b 73 2d 67 65 74 2d 6c 61 73 e 'tasks-get-las
7ae0: 74 20 23 66 20 28 6c 69 73 74 20 74 61 72 67 65 t #f (list targe
7af0: 74 20 72 75 6e 6e 61 6d 65 29 29 29 0a 0a 3b 3b t runname)))..;;
7b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b40: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 ======.;; A R C
7b50: 48 20 49 20 56 20 45 20 53 0a 3b 3b 3d 3d 3d 3d H I V E S.;;====
7b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ba0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ==..(define (rmt
7bb0: 3a 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c :archive-get-all
7bc0: 6f 63 61 74 69 6f 6e 73 20 20 74 65 73 74 6e 61 ocations testna
7bd0: 6d 65 20 69 74 65 6d 70 61 74 68 20 64 6e 65 65 me itempath dnee
7be0: 64 65 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ded). (rmt:send
7bf0: 2d 72 65 63 65 69 76 65 20 27 61 72 63 68 69 76 -receive 'archiv
7c00: 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e e-get-allocation
7c10: 73 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 6e s #f (list testn
7c20: 61 6d 65 20 69 74 65 6d 70 61 74 68 20 64 6e 65 ame itempath dne
7c30: 65 64 65 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 eded)))..(define
7c40: 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 72 65 (rmt:archive-re
7c50: 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d gister-block-nam
7c60: 65 20 62 64 69 73 6b 2d 69 64 20 61 72 63 68 69 e bdisk-id archi
7c70: 76 65 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a ve-path). (rmt:
7c80: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 72 send-receive 'ar
7c90: 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d 62 chive-register-b
7ca0: 6c 6f 63 6b 2d 6e 61 6d 65 20 23 66 20 28 6c 69 lock-name #f (li
7cb0: 73 74 20 62 64 69 73 6b 2d 69 64 20 61 72 63 68 st bdisk-id arch
7cc0: 69 76 65 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 ive-path)))..(de
7cd0: 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 fine (rmt:archiv
7ce0: 65 2d 61 6c 6c 6f 63 61 74 65 2d 74 65 73 74 73 e-allocate-tests
7cf0: 75 69 74 65 2f 61 72 65 61 2d 74 6f 2d 62 6c 6f uite/area-to-blo
7d00: 63 6b 20 62 6c 6f 63 6b 2d 69 64 20 74 65 73 74 ck block-id test
7d10: 73 75 69 74 65 2d 6e 61 6d 65 20 61 72 65 61 6b suite-name areak
7d20: 65 79 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ey). (rmt:send-
7d30: 72 65 63 65 69 76 65 20 27 61 72 63 68 69 76 65 receive 'archive
7d40: 2d 61 6c 6c 6f 63 61 74 65 2d 74 65 73 74 2d 74 -allocate-test-t
7d50: 6f 2d 62 6c 6f 63 6b 20 23 66 20 28 6c 69 73 74 o-block #f (list
7d60: 20 20 62 6c 6f 63 6b 2d 69 64 20 74 65 73 74 73 block-id tests
7d70: 75 69 74 65 2d 6e 61 6d 65 20 61 72 65 61 6b 65 uite-name areake
7d80: 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 y)))..(define (r
7d90: 6d 74 3a 61 72 63 68 69 76 65 2d 72 65 67 69 73 mt:archive-regis
7da0: 74 65 72 2d 64 69 73 6b 20 62 64 69 73 6b 2d 6e ter-disk bdisk-n
7db0: 61 6d 65 20 62 64 69 73 6b 2d 70 61 74 68 20 64 ame bdisk-path d
7dc0: 66 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 f). (rmt:send-r
7dd0: 65 63 65 69 76 65 20 27 61 72 63 68 69 76 65 2d eceive 'archive-
7de0: 72 65 67 69 73 74 65 72 2d 64 69 73 6b 20 23 66 register-disk #f
7df0: 20 28 6c 69 73 74 20 62 64 69 73 6b 2d 6e 61 6d (list bdisk-nam
7e00: 65 20 62 64 69 73 6b 2d 70 61 74 68 20 64 66 29 e bdisk-path df)
7e10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7e20: 3a 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 76 :test-set-archiv
7e30: 65 2d 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 e-block-id run-i
7e40: 64 20 74 65 73 74 2d 69 64 20 61 72 63 68 69 76 d test-id archiv
7e50: 65 2d 62 6c 6f 63 6b 2d 69 64 29 0a 20 20 28 72 e-block-id). (r
7e60: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7e70: 27 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 76 'test-set-archiv
7e80: 65 2d 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 e-block-id run-i
7e90: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
7ea0: 65 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d 62 est-id archive-b
7eb0: 6c 6f 63 6b 2d 69 64 29 29 29 0a 0a 28 64 65 66 lock-id)))..(def
7ec0: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 ine (rmt:test-ge
7ed0: 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d t-archive-block-
7ee0: 69 6e 66 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f info archive-blo
7ef0: 63 6b 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 ck-id). (rmt:se
7f00: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
7f10: 2d 67 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f -get-archive-blo
7f20: 63 6b 2d 69 6e 66 6f 20 23 66 20 28 6c 69 73 74 ck-info #f (list
7f30: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
7f40: 64 29 29 29 0a d))).