Artifact
052d2f86992d7c60027647a24802a8bf43971051:
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 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 72 6d 74 6d 6f 64 29 29 0a 28 64 unit rmtmod)).(d
03a0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 65 62 eclare (uses deb
03b0: 75 67 70 72 69 6e 74 29 29 0a 28 64 65 63 6c 61 ugprint)).(decla
03c0: 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d re (uses commonm
03d0: 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 od)).(declare (u
03e0: 73 65 73 20 64 62 66 69 6c 65 29 29 20 20 20 20 ses dbfile))
03f0: 3b 3b 20 6e 65 65 64 65 64 20 66 6f 72 20 72 65 ;; needed for re
0400: 63 6f 72 64 73 0a 0a 3b 3b 20 28 64 65 63 6c 61 cords..;; (decla
0410: 72 65 20 28 75 73 65 73 20 61 70 69 6d 6f 64 29 re (uses apimod)
0420: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0430: 73 65 73 20 61 70 69 6d 6f 64 2e 69 6d 70 6f 72 ses apimod.impor
0440: 74 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 t)).;; (declare
0450: 28 75 73 65 73 20 75 6c 65 78 29 29 0a 0a 3b 3b (uses ulex))..;;
0460: 20 28 69 6e 63 6c 75 64 65 20 22 75 6c 65 78 2f (include "ulex/
0470: 75 6c 65 78 2e 73 63 6d 22 29 0a 0a 28 6d 6f 64 ulex.scm")..(mod
0480: 75 6c 65 20 72 6d 74 6d 6f 64 0a 09 2a 0a 09 0a ule rmtmod..*...
0490: 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 20 63 (import scheme c
04a0: 68 69 63 6b 65 6e 20 64 61 74 61 2d 73 74 72 75 hicken data-stru
04b0: 63 74 75 72 65 73 20 65 78 74 72 61 73 20 6d 61 ctures extras ma
04c0: 74 63 68 61 62 6c 65 20 73 72 66 69 2d 36 39 29 tchable srfi-69)
04d0: 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 .(import (prefix
04e0: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
04f0: 3a 29 20 70 6f 73 69 78 20 74 79 70 65 64 2d 72 :) posix typed-r
0500: 65 63 6f 72 64 73 20 73 72 66 69 2d 31 38 29 0a ecords srfi-18).
0510: 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e 6d 6f (import commonmo
0520: 64 20 64 62 66 69 6c 65 20 64 65 62 75 67 70 72 d dbfile debugpr
0530: 69 6e 74 29 20 3b 3b 20 28 70 72 65 66 69 78 20 int) ;; (prefix
0540: 63 6f 6d 6d 6f 6e 6d 6f 64 20 63 6d 6f 64 3a 29 commonmod cmod:)
0550: 29 0a 3b 3b 20 28 69 6d 70 6f 72 74 20 61 70 69 ).;; (import api
0560: 6d 6f 64 29 0a 3b 3b 20 28 69 6d 70 6f 72 74 20 mod).;; (import
0570: 28 70 72 65 66 69 78 20 75 6c 65 78 20 75 6c 65 (prefix ulex ule
0580: 78 3a 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 x:))..(include "
0590: 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 db_records.scm")
05a0: 0a 0a 28 64 65 66 73 74 72 75 63 74 20 61 6c 6c ..(defstruct all
05b0: 64 61 74 0a 20 20 28 61 72 65 61 70 61 74 68 20 dat. (areapath
05c0: 23 66 29 0a 20 20 28 75 6c 65 78 64 61 74 20 20 #f). (ulexdat
05d0: 23 66 29 0a 20 20 29 0a 0a 3b 3b 20 68 6f 6c 64 #f). )..;; hold
05e0: 20 74 68 65 20 73 65 6e 64 2d 72 65 63 65 69 76 the send-receiv
05f0: 65 20 70 72 6f 63 20 69 6e 20 74 68 69 73 20 70 e proc in this p
0600: 61 72 61 6d 65 74 65 72 0a 28 64 65 66 69 6e 65 arameter.(define
0610: 20 72 6d 74 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 rmtmod:send-rec
0620: 65 69 76 65 20 23 66 29 20 3b 3b 20 28 6d 61 6b eive #f) ;; (mak
0630: 65 2d 70 61 72 61 6d 65 74 65 72 20 23 66 29 29 e-parameter #f))
0640: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 ==========.;; M
0690: 49 20 53 20 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d I S C.;;========
06a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
06e0: 3b 3b 20 68 61 6e 64 20 6f 66 66 20 61 20 63 61 ;; hand off a ca
06f0: 6c 6c 20 74 6f 20 6f 6e 65 20 6f 66 20 74 68 65 ll to one of the
0700: 20 64 62 3a 71 75 65 72 69 65 73 20 73 74 61 74 db:queries stat
0710: 65 6d 65 6e 74 73 0a 3b 3b 20 61 64 64 65 64 20 ements.;; added
0720: 72 75 6e 2d 69 64 20 74 6f 20 6d 61 6b 65 20 6c run-id to make l
0730: 6f 6f 6b 69 6e 67 20 75 70 20 74 68 65 20 63 6f ooking up the co
0740: 72 72 65 63 74 20 64 62 20 70 6f 73 73 69 62 6c rrect db possibl
0750: 65 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 e .;;.(define (r
0760: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
0770: 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 stmtname run-id
0780: 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 . params). (rmt
0790: 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 mod:send-receive
07a0: 20 27 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 72 'general-call r
07b0: 75 6e 2d 69 64 20 28 61 70 70 65 6e 64 20 28 6c un-id (append (l
07c0: 69 73 74 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e ist stmtname run
07d0: 2d 69 64 29 20 70 61 72 61 6d 73 29 29 29 0a 0a -id) params)))..
07e0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 69 6d ==========.;; im
0830: 70 6f 72 74 20 61 6e 20 73 65 78 70 72 20 66 69 port an sexpr fi
0840: 6c 65 20 69 6e 74 6f 20 74 68 65 20 64 62 0a 3b le into the db.;
0850: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0890: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
08a0: 20 28 72 6d 74 3a 69 6d 70 6f 72 74 2d 73 65 78 (rmt:import-sex
08b0: 70 72 20 73 65 78 70 72 2d 66 69 6c 65 29 0a 20 pr sexpr-file).
08c0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
08d0: 73 3f 20 73 65 78 70 72 2d 66 69 6c 65 29 0a 20 s? sexpr-file).
08e0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 (let* ((dat
08f0: 61 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 a (with-input-fr
0900: 6f 6d 2d 66 69 6c 65 20 73 65 78 70 72 2d 66 69 om-file sexpr-fi
0910: 6c 65 20 72 65 61 64 29 29 29 0a 09 28 66 6f 72 le read)))..(for
0920: 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 64 61 20 -each.. (lambda
0930: 28 74 61 72 67 2d 64 61 74 29 0a 09 20 20 20 28 (targ-dat).. (
0940: 72 6d 74 3a 69 6d 70 6f 72 74 2d 74 61 72 67 65 rmt:import-targe
0950: 74 20 74 61 72 67 2d 64 61 74 29 29 20 3b 3b 20 t targ-dat)) ;;
0960: 28 22 74 61 72 67 65 74 22 20 28 22 72 75 6e 31 ("target" ("run1
0970: 22 20 28 22 64 61 74 61 22 20 28 31 20 28 22 66 " ("data" (1 ("f
0980: 69 65 6c 64 22 20 2e 20 22 76 61 6c 75 65 22 29 ield" . "value")
0990: 20 2e 2e 2e 0a 09 20 64 61 74 61 29 29 0a 20 20 ..... data)).
09a0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 73 67 20 (let* ((msg
09b0: 28 63 6f 6e 63 20 22 45 52 52 4f 52 3a 20 66 69 (conc "ERROR: fi
09c0: 6c 65 20 22 73 65 78 70 72 2d 66 69 6c 65 22 20 le "sexpr-file"
09d0: 6e 6f 74 20 66 6f 75 6e 64 22 29 29 29 0a 09 28 not found")))..(
09e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
09f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0a00: 20 6d 73 67 29 0a 09 28 63 6f 6e 73 20 23 66 20 msg)..(cons #f
0a10: 6d 73 67 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg))))..(define
0a20: 20 28 72 6d 74 3a 69 6d 70 6f 72 74 2d 74 61 72 (rmt:import-tar
0a30: 67 65 74 20 74 61 72 67 2d 64 61 74 29 0a 20 20 get targ-dat).
0a40: 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 20 28 (let* ((target (
0a50: 63 61 72 20 74 61 72 67 2d 64 61 74 29 29 0a 09 car targ-dat))..
0a60: 20 28 64 61 74 61 20 20 20 28 63 64 72 20 74 61 (data (cdr ta
0a70: 72 67 2d 64 61 74 29 29 29 0a 20 20 20 20 28 66 rg-dat))). (f
0a80: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
0a90: 6d 62 64 61 20 28 72 75 6e 2d 64 61 74 29 0a 20 mbda (run-dat).
0aa0: 20 20 20 20 20 20 28 72 6d 74 3a 69 6d 70 6f 72 (rmt:impor
0ab0: 74 2d 72 75 6e 20 74 61 72 67 65 74 20 72 75 6e t-run target run
0ac0: 2d 64 61 74 29 29 20 3b 3b 20 28 22 72 75 6e 6e -dat)) ;; ("runn
0ad0: 61 6d 65 22 20 28 22 64 61 74 61 22 20 28 22 74 ame" ("data" ("t
0ae0: 65 73 74 69 64 22 20 28 22 66 69 65 6c 64 22 20 estid" ("field"
0af0: 2e 20 22 76 61 6c 75 65 22 29 20 2e 2e 2e 0a 20 . "value") ....
0b00: 20 20 20 20 64 61 74 61 29 29 29 0a 0a 28 64 65 data)))..(de
0b10: 66 69 6e 65 20 28 72 6d 74 3a 69 6d 70 6f 72 74 fine (rmt:import
0b20: 2d 72 75 6e 20 74 61 72 67 65 74 20 72 75 6e 2d -run target run-
0b30: 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 dat). (let* ((r
0b40: 75 6e 6e 61 6d 65 20 20 20 20 28 63 61 72 20 72 unname (car r
0b50: 75 6e 2d 64 61 74 29 29 0a 09 20 28 61 6c 6c 2d un-dat)).. (all-
0b60: 64 61 74 20 20 20 20 28 63 64 72 20 72 75 6e 2d dat (cdr run-
0b70: 64 61 74 29 29 0a 09 20 28 74 65 73 74 73 2d 64 dat)).. (tests-d
0b80: 61 74 61 20 28 61 6c 69 73 74 2d 72 65 66 20 22 ata (alist-ref "
0b90: 64 61 74 61 22 20 61 6c 6c 2d 64 61 74 20 65 71 data" all-dat eq
0ba0: 75 61 6c 3f 29 29 0a 09 20 28 72 75 6e 2d 6d 65 ual?)).. (run-me
0bb0: 74 61 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 ta (alist-ref
0bc0: 22 6d 65 74 61 22 20 61 6c 6c 2d 64 61 74 20 65 "meta" all-dat e
0bd0: 71 75 61 6c 3f 29 29 0a 20 20 20 20 20 20 20 20 qual?)).
0be0: 20 28 72 75 6e 2d 69 64 20 20 20 20 20 28 73 74 (run-id (st
0bf0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 6c ring->number (al
0c00: 69 73 74 2d 72 65 66 20 22 69 64 22 20 20 20 72 ist-ref "id" r
0c10: 75 6e 2d 6d 65 74 61 20 65 71 75 61 6c 3f 29 29 un-meta equal?))
0c20: 29 29 0a 0a 20 20 20 20 28 72 6d 74 3a 69 6e 73 )).. (rmt:ins
0c30: 65 72 74 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 ert-run run-id t
0c40: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 72 75 arget runname ru
0c50: 6e 2d 6d 65 74 61 29 0a 20 20 20 20 28 66 6f 72 n-meta). (for
0c60: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
0c70: 64 61 20 28 74 65 73 74 2d 64 61 74 29 0a 20 20 da (test-dat).
0c80: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
0c90: 74 2d 69 64 20 20 28 63 61 72 20 74 65 73 74 2d t-id (car test-
0ca0: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 74 65 dat)).. (te
0cb0: 73 74 2d 72 65 63 20 28 63 64 72 20 74 65 73 74 st-rec (cdr test
0cc0: 2d 64 61 74 29 29 29 0a 09 20 28 72 6d 74 3a 69 -dat))).. (rmt:i
0cd0: 6e 73 65 72 74 2d 74 65 73 74 20 72 75 6e 2d 69 nsert-test run-i
0ce0: 64 20 74 65 73 74 2d 72 65 63 29 29 29 0a 20 20 d test-rec))).
0cf0: 20 20 20 74 65 73 74 73 2d 64 61 74 61 29 29 29 tests-data)))
0d00: 0a 0a 3b 3b 20 69 6e 73 65 72 74 20 72 75 6e 20 ..;; insert run
0d10: 69 66 20 6e 6f 74 20 74 68 65 72 65 2c 20 72 65 if not there, re
0d20: 74 75 72 6e 20 69 64 20 65 69 74 68 65 72 20 77 turn id either w
0d30: 61 79 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ay.(define (rmt:
0d40: 69 6e 73 65 72 74 2d 72 75 6e 20 72 75 6e 2d 69 insert-run run-i
0d50: 64 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 d target runname
0d60: 20 72 75 6e 2d 6d 65 74 61 29 0a 20 20 3b 3b 20 run-meta). ;;
0d70: 6c 6f 6f 6b 20 66 6f 72 20 69 64 2c 20 72 65 74 look for id, ret
0d80: 75 72 6e 20 69 66 20 66 6f 75 6e 64 0a 20 20 28 urn if found. (
0d90: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
0da0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0db0: 20 22 49 6e 73 65 72 74 20 72 75 6e 3a 20 22 74 "Insert run: "t
0dc0: 61 72 67 65 74 22 2f 22 72 75 6e 6e 61 6d 65 29 arget"/"runname)
0dd0: 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 73 20 . (let* ((runs
0de0: 28 72 6d 74 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 (rmtmod:send-rec
0df0: 65 69 76 65 20 27 73 69 6d 70 6c 65 2d 67 65 74 eive 'simple-get
0e00: 2d 72 75 6e 73 20 23 66 0a 09 09 09 09 20 20 20 -runs #f.....
0e10: 20 3b 3b 20 20 20 20 72 75 6e 70 61 74 74 20 63 ;; runpatt c
0e20: 6f 75 6e 74 20 6f 66 66 73 65 74 20 74 61 72 67 ount offset targ
0e30: 65 74 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a et last-update).
0e40: 09 09 09 09 20 20 20 20 28 6c 69 73 74 20 72 75 .... (list ru
0e50: 6e 6e 61 6d 65 20 23 66 20 20 20 20 23 66 20 20 nname #f #f
0e60: 20 20 20 74 61 72 67 65 74 20 23 66 29 29 29 29 target #f))))
0e70: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
0e80: 72 75 6e 73 29 0a 20 20 20 20 20 20 20 28 62 65 runs). (be
0e90: 67 69 6e 0a 20 20 20 20 20 20 20 20 28 64 65 62 gin. (deb
0ea0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
0eb0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 ult-log-port* "i
0ec0: 6e 73 65 72 74 69 6e 67 20 72 75 6e 20 66 6f 72 nserting run for
0ed0: 20 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 runname " runna
0ee0: 6d 65 20 22 20 74 61 72 67 65 74 20 22 20 74 61 me " target " ta
0ef0: 72 67 65 74 29 0a 09 28 72 6d 74 6d 6f 64 3a 73 rget)..(rmtmod:s
0f00: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 69 6e 73 end-receive 'ins
0f10: 65 72 74 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 ert-run #f (list
0f20: 20 72 75 6e 2d 69 64 20 74 61 72 67 65 74 20 72 run-id target r
0f30: 75 6e 6e 61 6d 65 20 72 75 6e 2d 6d 65 74 61 29 unname run-meta)
0f40: 29 0a 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 ). ).
0f50: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
0f60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
0f70: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0f80: 74 2a 20 22 46 6f 75 6e 64 20 72 75 6e 2d 69 64 t* "Found run-id
0f90: 20 22 20 28 73 69 6d 70 6c 65 2d 72 75 6e 2d 69 " (simple-run-i
0fa0: 64 20 28 63 61 72 20 72 75 6e 73 29 29 20 22 20 d (car runs)) "
0fb0: 66 6f 72 20 72 75 6e 6e 61 6d 65 20 22 20 72 75 for runname " ru
0fc0: 6e 6e 61 6d 65 20 22 20 74 61 72 67 65 74 20 22 nname " target "
0fd0: 20 74 61 72 67 65 74 29 0a 09 28 73 69 6d 70 6c target)..(simpl
0fe0: 65 2d 72 75 6e 2d 69 64 20 28 63 61 72 20 72 75 e-run-id (car ru
0ff0: 6e 73 29 0a 20 20 20 20 20 20 20 20 29 0a 20 20 ns). ).
1000: 20 20 20 20 20 29 29 29 29 0a 0a 28 64 65 66 69 ))))..(defi
1010: 6e 65 20 28 72 6d 74 3a 69 6e 73 65 72 74 2d 74 ne (rmt:insert-t
1020: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
1030: 72 65 63 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 rec). (let* ((t
1040: 65 73 74 6e 61 6d 65 20 20 28 61 6c 69 73 74 2d estname (alist-
1050: 72 65 66 20 22 74 65 73 74 6e 61 6d 65 22 20 74 ref "testname" t
1060: 65 73 74 2d 72 65 63 20 65 71 75 61 6c 3f 29 29 est-rec equal?))
1070: 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 28 61 .. (item-path (a
1080: 6c 69 73 74 2d 72 65 66 20 22 69 74 65 6d 5f 70 list-ref "item_p
1090: 61 74 68 22 20 74 65 73 74 2d 72 65 63 20 65 71 ath" test-rec eq
10a0: 75 61 6c 3f 29 29 29 0a 20 20 20 20 28 72 6d 74 ual?))). (rmt
10b0: 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 mod:send-receive
10c0: 20 27 69 6e 73 65 72 74 2d 74 65 73 74 20 72 75 'insert-test ru
10d0: 6e 2d 69 64 20 74 65 73 74 2d 72 65 63 29 29 29 n-id test-rec)))
10e0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
10f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 ==========.;; T
1130: 20 45 20 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d E S T S.;;=====
1140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1180: 3d 0a 0a 3b 3b 20 4a 75 73 74 20 73 6f 6d 65 20 =..;; Just some
1190: 73 79 6e 74 61 74 69 63 20 73 75 67 61 72 0a 28 syntatic sugar.(
11a0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 67 69 define (rmt:regi
11b0: 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 ster-test run-id
11c0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
11d0: 70 61 74 68 29 0a 20 20 28 61 73 73 65 72 74 20 path). (assert
11e0: 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 (number? run-id)
11f0: 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 "FATAL: Run id
1200: 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 required."). (r
1210: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
1220: 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 'register-test r
1230: 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 un-id run-id tes
1240: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
1250: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
1260: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e :get-test-id run
1270: 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 -id testname ite
1280: 6d 2d 70 61 74 68 29 0a 20 20 28 61 73 73 65 72 m-path). (asser
1290: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
12a0: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
12b0: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
12c0: 28 72 6d 74 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 (rmtmod:send-rec
12d0: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 2d 69 eive 'get-test-i
12e0: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
12f0: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 un-id testname i
1300: 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 tem-path)))..(de
1310: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 fine (rmt:get-te
1320: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 st-info-by-id ru
1330: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
1340: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 74 65 73 (if (number? tes
1350: 74 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 t-id). (rmt
1360: 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 mod:send-receive
1370: 20 27 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 'get-test-info-
1380: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 by-id run-id (li
1390: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
13a0: 64 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e d)). (begin
13b0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
13c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
13d0: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 42 61 rt* "WARNING: Ba
13e0: 64 20 64 61 74 61 20 68 61 6e 64 65 64 20 74 6f d data handed to
13f0: 20 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e rmt:get-test-in
1400: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 3d fo-by-id run-id=
1410: 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 " run-id ", test
1420: 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 29 0a 09 -id=" test-id)..
1430: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
1440: 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
1450: 2d 70 6f 72 74 29 29 0a 09 23 66 29 29 29 0a 0a -port))..#f)))..
1460: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
1470: 2d 74 65 73 74 2d 73 74 61 74 65 2d 73 74 61 74 -test-state-stat
1480: 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
1490: 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 6d test-id). (rmtm
14a0: 6f 64 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 od:send-receive
14b0: 27 67 65 74 2d 74 65 73 74 2d 73 74 61 74 65 2d 'get-test-state-
14c0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
14d0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
14e0: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 test-id)))..(de
14f0: 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 fine (rmt:test-g
1500: 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 et-rundir-from-t
1510: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 est-id run-id te
1520: 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 6d 6f 64 st-id). (rmtmod
1530: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
1540: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 est-get-rundir-f
1550: 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d rom-test-id run-
1560: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
1570: 74 65 73 74 2d 69 64 29 29 29 0a 0a 3b 3b 20 28 test-id)))..;; (
1580: 64 65 66 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e define (rmt:open
1590: 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 73 74 -test-db-by-test
15a0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
15b0: 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 id #!key (work-a
15c0: 72 65 61 20 23 66 29 29 0a 3b 3b 20 20 20 28 61 rea #f)).;; (a
15d0: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
15e0: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
15f0: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
1600: 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 74 ).;; (let* ((t
1610: 65 73 74 2d 70 61 74 68 20 28 69 66 20 28 73 74 est-path (if (st
1620: 72 69 6e 67 3f 20 77 6f 72 6b 2d 61 72 65 61 29 ring? work-area)
1630: 0a 3b 3b 20 09 09 09 77 6f 72 6b 2d 61 72 65 61 .;; ...work-area
1640: 0a 3b 3b 20 09 09 09 28 72 6d 74 3a 74 65 73 74 .;; ...(rmt:test
1650: 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d -get-rundir-from
1660: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
1670: 74 65 73 74 2d 69 64 29 29 29 29 0a 3b 3b 20 20 test-id)))).;;
1680: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1690: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
16a0: 6f 72 74 2a 20 22 54 45 53 54 20 50 41 54 48 3a ort* "TEST PATH:
16b0: 20 22 20 74 65 73 74 2d 70 61 74 68 29 0a 3b 3b " test-path).;;
16c0: 20 20 20 20 20 28 6f 70 65 6e 2d 74 65 73 74 2d (open-test-
16d0: 64 62 20 74 65 73 74 2d 70 61 74 68 29 29 29 0a db test-path))).
16e0: 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 .;; WARNING: Thi
16f0: 73 20 63 75 72 72 65 6e 74 6c 79 20 62 79 70 61 s currently bypa
1700: 73 73 65 73 20 74 68 65 20 74 72 61 6e 73 61 63 sses the transac
1710: 74 69 6f 6e 20 77 72 61 70 70 65 64 20 77 72 69 tion wrapped wri
1720: 74 65 73 20 73 79 73 74 65 6d 0a 28 64 65 66 69 tes system.(defi
1730: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 ne (rmt:test-set
1740: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
1750: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
1760: 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 id newstate news
1770: 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 tatus newcomment
1780: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
1790: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
17a0: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
17b0: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 6d 6f ired."). (rmtmo
17c0: 64 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 d:send-receive '
17d0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
17e0: 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d tatus-by-id run-
17f0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
1800: 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 test-id newstate
1810: 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 6f newstatus newco
1820: 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e mment)))..(defin
1830: 65 20 28 72 6d 74 3a 73 65 74 2d 74 65 73 74 73 e (rmt:set-tests
1840: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
1850: 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 20 63 n-id testnames c
1860: 75 72 72 73 74 61 74 65 20 63 75 72 72 73 74 61 urrstate currsta
1870: 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 tus newstate new
1880: 73 74 61 74 75 73 29 0a 20 20 28 61 73 73 65 72 status). (asser
1890: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
18a0: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
18b0: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
18c0: 28 72 6d 74 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 (rmtmod:send-rec
18d0: 65 69 76 65 20 27 73 65 74 2d 74 65 73 74 73 2d eive 'set-tests-
18e0: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
18f0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
1900: 20 74 65 73 74 6e 61 6d 65 73 20 63 75 72 72 73 testnames currs
1910: 74 61 74 65 20 63 75 72 72 73 74 61 74 75 73 20 tate currstatus
1920: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
1930: 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 us)))..(define (
1940: 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f rmt:get-tests-fo
1950: 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 65 73 r-run run-id tes
1960: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
1970: 74 75 73 65 73 20 6f 66 66 73 65 74 20 6c 69 6d tuses offset lim
1980: 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 2d 62 it not-in sort-b
1990: 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 y sort-order qry
19a0: 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 65 vals last-update
19b0: 20 6d 6f 64 65 29 0a 20 20 28 61 73 73 65 72 74 mode). (assert
19c0: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
19d0: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
19e0: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 3b required."). ;
19f0: 3b 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 ; (if (number? r
1a00: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 6d 6f 64 un-id). (rmtmod
1a10: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
1a20: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
1a30: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
1a40: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 n-id testpatt st
1a50: 61 74 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 ates statuses of
1a60: 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 fset limit not-i
1a70: 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f n sort-by sort-o
1a80: 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 rder qryvals las
1a90: 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 29 29 t-update mode)))
1aa0: 0a 20 20 3b 3b 20 20 20 20 28 62 65 67 69 6e 0a . ;; (begin.
1ab0: 20 20 3b 3b 09 28 64 65 62 75 67 3a 70 72 69 6e ;;.(debug:prin
1ac0: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
1ad0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
1ae0: 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
1af0: 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 20 run called with
1b00: 62 61 64 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e bad run-id=" run
1b10: 2d 69 64 29 0a 20 20 3b 3b 09 28 70 72 69 6e 74 -id). ;;.(print
1b20: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
1b30: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
1b40: 29 0a 20 20 3b 3b 09 27 28 29 29 29 29 0a 0a 28 ). ;;.'())))..(
1b50: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
1b60: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 73 74 tests-for-run-st
1b70: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
1b80: 64 20 74 65 73 74 70 61 74 74 20 6c 61 73 74 2d d testpatt last-
1b90: 75 70 64 61 74 65 29 0a 20 20 28 61 73 73 65 72 update). (asser
1ba0: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
1bb0: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
1bc0: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
1bd0: 28 72 6d 74 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 (rmtmod:send-rec
1be0: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d eive 'get-tests-
1bf0: 66 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 for-run-state-st
1c00: 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 atus run-id (lis
1c10: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 t run-id testpat
1c20: 74 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 t last-update)))
1c30: 0a 0a 3b 3b 20 67 65 74 20 73 74 75 66 66 20 76 ..;; get stuff v
1c40: 69 61 20 73 79 6e 63 68 61 73 68 20 0a 28 64 65 ia synchash .(de
1c50: 66 69 6e 65 20 28 72 6d 74 3a 73 79 6e 63 68 61 fine (rmt:syncha
1c60: 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 70 72 sh-get run-id pr
1c70: 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 oc synckey keynu
1c80: 6d 20 70 61 72 61 6d 73 29 0a 20 20 28 61 73 73 m params). (ass
1c90: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
1ca0: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
1cb0: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
1cc0: 20 20 28 72 6d 74 6d 6f 64 3a 73 65 6e 64 2d 72 (rmtmod:send-r
1cd0: 65 63 65 69 76 65 20 27 73 79 6e 63 68 61 73 68 eceive 'synchash
1ce0: 2d 67 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 -get run-id (lis
1cf0: 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 79 t run-id proc sy
1d00: 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 72 nckey keynum par
1d10: 61 6d 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ams)))..(define
1d20: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (rmt:get-tests-f
1d30: 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 or-run-mindata r
1d40: 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 un-id testpatt s
1d50: 74 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 tates status not
1d60: 2d 69 6e 29 0a 20 20 28 61 73 73 65 72 74 20 28 -in). (assert (
1d70: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
1d80: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
1d90: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
1da0: 74 6d 6f 64 3a 73 65 6e 64 2d 72 65 63 65 69 76 tmod:send-receiv
1db0: 65 20 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 e 'get-tests-for
1dc0: 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e -run-mindata run
1dd0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
1de0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
1df0: 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 status not-in))
1e00: 29 0a 20 20 0a 3b 3b 20 73 74 61 74 65 20 61 6e ). .;; state an
1e10: 64 20 73 74 61 74 75 73 20 61 72 65 20 65 78 74 d status are ext
1e20: 72 61 20 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 ra hints not usu
1e30: 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 ally used in the
1e40: 20 63 61 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a calculation.;;.
1e50: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 (define (rmt:set
1e60: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
1e70: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 d-roll-up-items
1e80: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
1e90: 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 item-path state
1ea0: 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 status comment)
1eb0: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
1ec0: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
1ed0: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
1ee0: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 6d 6f 64 red."). (rmtmod
1ef0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
1f00: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
1f10: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
1f20: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
1f30: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
1f40: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
1f50: 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 29 status comment))
1f60: 29 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )...;;==========
1f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
1fb0: 4d 61 69 6e 74 65 6e 61 6e 63 65 0a 3b 3b 3d 3d Maintenance.;;==
1fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2000: 3d 3d 3d 3d 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ====...(define (
2010: 72 6d 74 3a 67 65 74 2d 74 6f 70 6c 65 76 65 6c rmt:get-toplevel
2020: 73 2d 61 6e 64 2d 69 6e 63 6f 6d 70 6c 65 74 65 s-and-incomplete
2030: 73 20 72 75 6e 2d 69 64 20 72 75 6e 6e 69 6e 67 s run-id running
2040: 2d 64 65 61 64 74 69 6d 65 20 72 65 6d 6f 74 65 -deadtime remote
2050: 68 6f 73 74 73 74 61 72 74 2d 64 65 61 64 74 69 hoststart-deadti
2060: 6d 65 29 0a 20 20 28 72 6d 74 6d 6f 64 3a 73 65 me). (rmtmod:se
2070: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
2080: 74 6f 70 6c 65 76 65 6c 73 2d 61 6e 64 2d 69 6e toplevels-and-in
2090: 63 6f 6d 70 6c 65 74 65 73 20 72 75 6e 2d 69 64 completes run-id
20a0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 72 75 (list run-id ru
20b0: 6e 6e 69 6e 67 2d 64 65 61 64 74 69 6d 65 20 72 nning-deadtime r
20c0: 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 2d 64 emotehoststart-d
20d0: 65 61 64 74 69 6d 65 29 29 29 0a 0a 28 64 65 66 eadtime)))..(def
20e0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 61 ine (rmt:get-sta
20f0: 74 75 73 2d 66 72 6f 6d 2d 66 69 6e 61 6c 2d 73 tus-from-final-s
2100: 74 61 74 75 73 2d 66 69 6c 65 20 72 75 6e 2d 64 tatus-file run-d
2110: 69 72 29 0a 20 20 28 6c 65 74 20 28 28 69 6e 66 ir). (let ((inf
2120: 69 6c 65 20 28 63 6f 6e 63 20 72 75 6e 2d 64 69 ile (conc run-di
2130: 72 20 22 2f 2e 66 69 6e 61 6c 2d 73 74 61 74 75 r "/.final-statu
2140: 73 22 29 29 29 0a 20 20 20 20 3b 3b 20 66 69 72 s"))). ;; fir
2150: 73 74 20 76 65 72 69 66 79 20 77 65 20 61 72 65 st verify we are
2160: 20 61 62 6c 65 20 74 6f 20 77 72 69 74 65 20 74 able to write t
2170: 68 65 20 6f 75 74 70 75 74 20 66 69 6c 65 0a 20 he output file.
2180: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
2190: 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 69 e-read-access? i
21a0: 6e 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 20 nfile)).
21b0: 28 62 65 67 69 6e 20 0a 09 20 20 28 64 65 62 75 (begin .. (debu
21c0: 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 g:print 2 *defau
21d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
21e0: 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 72 65 61 64 ROR: cannot read
21f0: 20 22 20 69 6e 66 69 6c 65 29 0a 20 20 20 20 20 " infile).
2200: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2210: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
2220: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 72 -port* "ERROR: r
2230: 75 6e 2d 64 69 72 20 69 73 20 22 20 72 75 6e 2d un-dir is " run-
2240: 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 23 dir). #
2250: 66 0a 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 f. ).
2260: 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 (with-inpu
2270: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 69 6e 66 69 t-from-file infi
2280: 6c 65 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 09 le read-lines)..
2290: 29 29 29 0a 20 20 0a 3b 3b 20 20 73 65 6c 65 63 ))). .;; selec
22a0: 74 20 65 6e 64 5f 74 69 6d 65 2d 6e 6f 77 20 66 t end_time-now f
22b0: 72 6f 6d 0a 3b 3b 20 20 20 20 20 20 28 73 65 6c rom.;; (sel
22c0: 65 63 74 20 74 65 73 74 6e 61 6d 65 2c 69 74 65 ect testname,ite
22d0: 6d 5f 70 61 74 68 2c 65 76 65 6e 74 5f 74 69 6d m_path,event_tim
22e0: 65 2b 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 61 e+run_duration a
22f0: 73 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 s.;;
2300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 6e en
2310: 64 5f 74 69 6d 65 2c 73 74 72 66 74 69 6d 65 28 d_time,strftime(
2320: 27 25 73 27 2c 27 6e 6f 77 27 29 20 61 73 20 6e '%s','now') as n
2330: 6f 77 20 66 72 6f 6d 20 74 65 73 74 73 20 77 68 ow from tests wh
2340: 65 72 65 20 73 74 61 74 65 20 69 6e 0a 3b 3b 20 ere state in.;;
2350: 20 20 20 20 20 28 27 52 55 4e 4e 49 4e 47 27 2c ('RUNNING',
2360: 27 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 'REMOTEHOSTSTART
2370: 27 2c 27 4c 41 55 4e 43 48 45 44 27 29 29 3b 0a ','LAUNCHED'));.
2380: 3b 3b 0a 3b 3b 20 4e 4f 54 20 45 41 53 59 20 54 ;;.;; NOT EASY T
2390: 4f 20 4d 49 47 52 41 54 45 20 54 4f 20 64 62 7b O MIGRATE TO db{
23a0: 66 69 6c 65 2c 6d 6f 64 7d 0a 3b 3b 0a 28 64 65 file,mod}.;;.(de
23b0: 66 69 6e 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 fine (rmt:find-a
23c0: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
23d0: 74 65 2d 65 6e 67 69 6e 65 20 72 75 6e 2d 69 64 te-engine run-id
23e0: 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 20 63 66 ovr-deadtime cf
23f0: 67 2d 64 65 61 64 74 69 6d 65 20 74 65 73 74 2d g-deadtime test-
2400: 73 74 61 74 73 2d 75 70 64 61 74 65 2d 70 65 72 stats-update-per
2410: 69 6f 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 iod). (let* ((i
2420: 6e 63 6f 6d 70 6c 65 74 65 64 20 27 28 29 29 0a ncompleted '()).
2430: 09 20 28 6f 6c 64 6c 61 75 6e 63 68 65 64 20 27 . (oldlaunched '
2440: 28 29 29 0a 09 20 28 74 6f 70 6c 65 76 65 6c 73 ()).. (toplevels
2450: 20 20 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 '()).
2460: 20 20 3b 3b 20 54 68 65 20 64 65 66 61 75 6c 74 ;; The default
2470: 20 72 75 6e 6e 69 6e 67 2d 64 65 61 64 74 69 6d running-deadtim
2480: 65 20 69 73 20 37 32 30 20 73 65 63 6f 6e 64 73 e is 720 seconds
2490: 20 3d 20 31 32 20 6d 69 6e 75 74 65 73 2e 0a 20 = 12 minutes..
24a0: 20 20 20 20 20 20 20 20 20 3b 3b 20 22 28 72 75 ;; "(ru
24b0: 6e 6e 69 6e 67 2d 64 65 61 64 74 69 6d 65 2d 64 nning-deadtime-d
24c0: 65 66 61 75 6c 74 20 28 2b 20 73 65 72 76 65 72 efault (+ server
24d0: 2d 73 74 61 72 74 2d 61 6c 6c 6f 77 61 6e 63 65 -start-allowance
24e0: 20 28 2a 20 32 20 6c 61 75 6e 63 68 2d 6d 6f 6e (* 2 launch-mon
24f0: 69 74 6f 72 2d 70 65 72 69 6f 64 29 29 29 22 20 itor-period)))"
2500: 3d 20 32 30 30 20 2b 20 28 32 20 2a 20 28 32 30 = 200 + (2 * (20
2510: 30 20 2b 20 33 30 20 2b 20 33 30 29 29 0a 20 20 0 + 30 + 30)).
2520: 20 20 20 20 20 20 20 28 64 65 61 64 74 69 6d 65 (deadtime
2530: 2d 74 72 69 6d 20 28 6f 72 20 6f 76 72 2d 64 65 -trim (or ovr-de
2540: 61 64 74 69 6d 65 20 63 66 67 2d 64 65 61 64 74 adtime cfg-deadt
2550: 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 ime)). (
2560: 73 65 72 76 65 72 2d 73 74 61 72 74 2d 61 6c 6c server-start-all
2570: 6f 77 61 6e 63 65 20 32 30 30 29 0a 20 20 20 20 owance 200).
2580: 20 20 20 20 20 28 73 65 72 76 65 72 2d 6f 76 65 (server-ove
2590: 72 6c 6f 61 64 65 64 2d 62 75 64 67 65 74 20 32 rloaded-budget 2
25a0: 30 30 29 0a 20 20 20 20 20 20 20 20 20 28 6c 61 00). (la
25b0: 75 6e 63 68 2d 6d 6f 6e 69 74 6f 72 2d 6f 66 66 unch-monitor-off
25c0: 2d 74 69 6d 65 20 28 6f 72 20 74 65 73 74 2d 73 -time (or test-s
25d0: 74 61 74 73 2d 75 70 64 61 74 65 2d 70 65 72 69 tats-update-peri
25e0: 6f 64 20 33 30 29 29 0a 20 20 20 20 20 20 20 20 od 30)).
25f0: 20 28 6c 61 75 6e 63 68 2d 6d 6f 6e 69 74 6f 72 (launch-monitor
2600: 2d 6f 6e 2d 74 69 6d 65 2d 62 75 64 67 65 74 20 -on-time-budget
2610: 33 30 29 0a 20 20 20 20 20 20 20 20 20 28 6c 61 30). (la
2620: 75 6e 63 68 2d 6d 6f 6e 69 74 6f 72 2d 70 65 72 unch-monitor-per
2630: 69 6f 64 20 28 2b 20 6c 61 75 6e 63 68 2d 6d 6f iod (+ launch-mo
2640: 6e 69 74 6f 72 2d 6f 66 66 2d 74 69 6d 65 20 6c nitor-off-time l
2650: 61 75 6e 63 68 2d 6d 6f 6e 69 74 6f 72 2d 6f 6e aunch-monitor-on
2660: 2d 74 69 6d 65 2d 62 75 64 67 65 74 20 73 65 72 -time-budget ser
2670: 76 65 72 2d 6f 76 65 72 6c 6f 61 64 65 64 2d 62 ver-overloaded-b
2680: 75 64 67 65 74 29 29 0a 20 20 20 20 20 20 20 20 udget)).
2690: 20 28 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 (remotehoststar
26a0: 74 2d 64 65 61 64 74 69 6d 65 2d 64 65 66 61 75 t-deadtime-defau
26b0: 6c 74 20 28 2b 20 73 65 72 76 65 72 2d 73 74 61 lt (+ server-sta
26c0: 72 74 2d 61 6c 6c 6f 77 61 6e 63 65 20 73 65 72 rt-allowance ser
26d0: 76 65 72 2d 6f 76 65 72 6c 6f 61 64 65 64 2d 62 ver-overloaded-b
26e0: 75 64 67 65 74 20 33 30 29 29 0a 20 20 20 20 20 udget 30)).
26f0: 20 20 20 20 28 72 65 6d 6f 74 65 68 6f 73 74 73 (remotehosts
2700: 74 61 72 74 2d 64 65 61 64 74 69 6d 65 20 28 6f tart-deadtime (o
2710: 72 20 64 65 61 64 74 69 6d 65 2d 74 72 69 6d 20 r deadtime-trim
2720: 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 2d remotehoststart-
2730: 64 65 61 64 74 69 6d 65 2d 64 65 66 61 75 6c 74 deadtime-default
2740: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 6e )). (run
2750: 6e 69 6e 67 2d 64 65 61 64 74 69 6d 65 2d 64 65 ning-deadtime-de
2760: 66 61 75 6c 74 20 28 2b 20 73 65 72 76 65 72 2d fault (+ server-
2770: 73 74 61 72 74 2d 61 6c 6c 6f 77 61 6e 63 65 20 start-allowance
2780: 28 2a 20 32 20 6c 61 75 6e 63 68 2d 6d 6f 6e 69 (* 2 launch-moni
2790: 74 6f 72 2d 70 65 72 69 6f 64 29 29 29 0a 20 20 tor-period))).
27a0: 20 20 20 20 20 20 20 28 72 75 6e 6e 69 6e 67 2d (running-
27b0: 64 65 61 64 74 69 6d 65 20 28 6f 72 20 64 65 61 deadtime (or dea
27c0: 64 74 69 6d 65 2d 74 72 69 6d 20 72 75 6e 6e 69 dtime-trim runni
27d0: 6e 67 2d 64 65 61 64 74 69 6d 65 2d 64 65 66 61 ng-deadtime-defa
27e0: 75 6c 74 29 29 29 20 3b 3b 20 74 77 6f 20 6d 69 ult))) ;; two mi
27f0: 6e 75 74 65 73 20 28 33 30 20 73 65 63 6f 6e 64 nutes (30 second
2800: 73 20 62 65 74 77 65 65 6e 20 75 70 64 61 74 65 s between update
2810: 73 2c 20 74 68 69 73 20 6c 65 61 76 65 73 20 33 s, this leaves 3
2820: 78 20 67 72 61 63 65 20 70 65 72 69 6f 64 29 0a x grace period).
2830: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
2840: 74 2d 69 6e 66 6f 20 34 20 20 2a 64 65 66 61 75 t-info 4 *defau
2850: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 75 lt-log-port* "ru
2860: 6e 6e 69 6e 67 2d 64 65 61 64 74 69 6d 65 20 3d nning-deadtime =
2870: 20 22 20 72 75 6e 6e 69 6e 67 2d 64 65 61 64 74 " running-deadt
2880: 69 6d 65 29 0a 20 20 20 20 28 64 65 62 75 67 3a ime). (debug:
2890: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 20 2a 64 print-info 4 *d
28a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
28b0: 20 22 64 65 61 64 74 69 6d 65 2d 74 72 69 6d 20 "deadtime-trim
28c0: 3d 20 22 20 64 65 61 64 74 69 6d 65 2d 74 72 69 = " deadtime-tri
28d0: 6d 29 0a 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 m).. (let* ((
28e0: 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 74 6f 70 dat (rmt:get-top
28f0: 6c 65 76 65 6c 73 2d 61 6e 64 2d 69 6e 63 6f 6d levels-and-incom
2900: 70 6c 65 74 65 73 20 72 75 6e 2d 69 64 20 72 75 pletes run-id ru
2910: 6e 6e 69 6e 67 2d 64 65 61 64 74 69 6d 65 20 72 nning-deadtime r
2920: 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 2d 64 emotehoststart-d
2930: 65 61 64 74 69 6d 65 29 29 29 0a 20 20 20 20 20 eadtime))).
2940: 20 28 73 65 74 21 20 6f 6c 64 6c 61 75 6e 63 68 (set! oldlaunch
2950: 65 64 20 28 6c 69 73 74 2d 72 65 66 20 64 61 74 ed (list-ref dat
2960: 20 31 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 1)). (set!
2970: 20 74 6f 70 6c 65 76 65 6c 73 20 20 20 28 6c 69 toplevels (li
2980: 73 74 2d 72 65 66 20 64 61 74 20 32 29 29 0a 20 st-ref dat 2)).
2990: 20 20 20 20 20 28 73 65 74 21 20 69 6e 63 6f 6d (set! incom
29a0: 70 6c 65 74 65 64 20 28 6c 69 73 74 2d 72 65 66 pleted (list-ref
29b0: 20 64 61 74 20 30 29 29 29 0a 0a 20 20 20 20 28 dat 0))).. (
29c0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
29d0: 20 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 18 *default-log
29e0: 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 22 20 -port* "Found "
29f0: 28 6c 65 6e 67 74 68 20 6f 6c 64 6c 61 75 6e 63 (length oldlaunc
2a00: 68 65 64 29 20 22 20 6f 6c 64 20 4c 41 55 4e 43 hed) " old LAUNC
2a10: 48 45 44 20 69 74 65 6d 73 2c 20 22 0a 09 09 20 HED items, "...
2a20: 20 20 20 20 20 28 6c 65 6e 67 74 68 20 74 6f 70 (length top
2a30: 6c 65 76 65 6c 73 29 20 22 20 6f 6c 64 20 4c 41 levels) " old LA
2a40: 55 4e 43 48 45 44 20 74 6f 70 6c 65 76 65 6c 20 UNCHED toplevel
2a50: 74 65 73 74 73 20 61 6e 64 20 22 0a 09 09 20 20 tests and "...
2a60: 20 20 20 20 28 6c 65 6e 67 74 68 20 69 6e 63 6f (length inco
2a70: 6d 70 6c 65 74 65 64 29 20 22 20 74 65 73 74 73 mpleted) " tests
2a80: 20 6d 61 72 6b 65 64 20 52 55 4e 4e 49 4e 47 20 marked RUNNING
2a90: 62 75 74 20 61 70 70 61 72 65 6e 74 6c 79 20 64 but apparently d
2aa0: 65 61 64 2e 22 29 0a 20 20 0a 20 20 20 20 3b 3b ead."). . ;;
2ab0: 20 54 68 65 73 65 20 61 72 65 20 64 65 66 75 6e These are defun
2ac0: 63 74 20 74 65 73 74 73 2c 20 64 6f 20 6e 6f 74 ct tests, do not
2ad0: 20 64 6f 20 61 6c 6c 20 74 68 65 20 6f 76 65 72 do all the over
2ae0: 68 65 61 64 20 6f 66 20 73 65 74 2d 73 74 61 74 head of set-stat
2af0: 65 2d 73 74 61 74 75 73 2e 20 46 6f 72 63 65 20 e-status. Force
2b00: 74 68 65 6d 20 74 6f 20 49 4e 43 4f 4d 50 4c 45 them to INCOMPLE
2b10: 54 45 2e 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b TE.. ;;. ;
2b20: 3b 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 ; (db:delay-if-b
2b30: 75 73 79 20 64 62 64 61 74 29 0a 20 20 20 20 28 usy dbdat). (
2b40: 6c 65 74 2a 20 28 28 6d 69 6e 2d 69 6e 63 6f 6d let* ((min-incom
2b50: 70 6c 65 74 65 64 2d 69 64 73 20 28 6d 61 70 20 pleted-ids (map
2b60: 63 61 72 20 69 6e 63 6f 6d 70 6c 65 74 65 64 29 car incompleted)
2b70: 29 20 3b 3b 20 64 6f 20 27 65 6d 20 61 6c 6c 0a ) ;; do 'em all.
2b80: 09 20 20 20 28 61 6c 6c 2d 69 64 73 20 20 20 20 . (all-ids
2b90: 20 20 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 (append
2ba0: 20 6d 69 6e 2d 69 6e 63 6f 6d 70 6c 65 74 65 64 min-incompleted
2bb0: 2d 69 64 73 20 28 6d 61 70 20 63 61 72 20 6f 6c -ids (map car ol
2bc0: 64 6c 61 75 6e 63 68 65 64 29 29 29 29 0a 20 20 dlaunched)))).
2bd0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
2be0: 74 68 20 61 6c 6c 2d 69 64 73 29 20 30 29 0a 09 th all-ids) 0)..
2bf0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b (begin.. ;;
2c00: 20 28 6c 61 75 6e 63 68 3a 69 73 2d 74 65 73 74 (launch:is-test
2c10: 2d 61 6c 69 76 65 20 22 6c 6f 63 61 6c 68 6f 73 -alive "localhos
2c20: 74 22 20 34 33 35 29 0a 09 20 20 20 20 28 64 65 t" 435).. (de
2c30: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2c40: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2c50: 57 41 52 4e 49 4e 47 3a 20 4d 61 72 6b 69 6e 67 WARNING: Marking
2c60: 20 74 65 73 74 28 73 29 3b 20 22 20 28 73 74 72 test(s); " (str
2c70: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
2c80: 28 6d 61 70 20 63 6f 6e 63 20 61 6c 6c 2d 69 64 (map conc all-id
2c90: 73 29 20 22 2c 20 22 29 0a 09 09 09 20 22 20 61 s) ", ").... " a
2ca0: 73 20 44 45 41 44 22 29 0a 09 20 20 20 20 28 66 s DEAD").. (f
2cb0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 20 or-each.
2cc0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
2cd0: 73 74 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 st-id).
2ce0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 (let* ((ti
2cf0: 6e 66 6f 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 nfo (rmt:get-t
2d00: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 est-info-by-id r
2d10: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a un-id test-id)).
2d20: 09 09 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 .. (run-dir
2d30: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
2d40: 6e 64 69 72 20 20 20 20 20 74 69 6e 66 6f 29 29 ndir tinfo))
2d50: 0a 09 09 20 20 20 20 20 20 28 68 6f 73 74 20 20 ... (host
2d60: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 68 (db:test-get-h
2d70: 6f 73 74 20 20 20 20 20 20 20 74 69 6e 66 6f 29 ost tinfo)
2d80: 29 0a 09 09 20 20 20 20 20 20 28 70 69 64 20 20 )... (pid
2d90: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
2da0: 70 72 6f 63 65 73 73 5f 69 64 20 74 69 6e 66 6f process_id tinfo
2db0: 29 29 0a 09 09 20 20 20 20 20 20 28 72 65 73 75 ))... (resu
2dc0: 6c 74 20 28 72 6d 74 3a 67 65 74 2d 73 74 61 74 lt (rmt:get-stat
2dd0: 75 73 2d 66 72 6f 6d 2d 66 69 6e 61 6c 2d 73 74 us-from-final-st
2de0: 61 74 75 73 2d 66 69 6c 65 20 72 75 6e 2d 64 69 atus-file run-di
2df0: 72 29 29 29 0a 09 09 20 28 69 66 20 28 61 6e 64 r)))... (if (and
2e00: 20 28 6c 69 73 74 3f 20 72 65 73 75 6c 74 29 20 (list? result)
2e10: 28 3e 20 28 6c 65 6e 67 74 68 20 72 65 73 75 6c (> (length resul
2e20: 74 29 20 31 29 20 28 65 71 75 61 6c 3f 20 22 50 t) 1) (equal? "P
2e30: 41 53 53 22 20 28 63 61 64 72 20 72 65 73 75 6c ASS" (cadr resul
2e40: 74 29 29 20 28 65 71 75 61 6c 3f 20 22 43 4f 4d t)) (equal? "COM
2e50: 50 4c 45 54 45 44 22 20 28 63 61 72 20 72 65 73 PLETED" (car res
2e60: 75 6c 74 29 29 29 20 0a 09 09 20 20 20 20 20 28 ult))) ... (
2e70: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 28 begin... (
2e80: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2e90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2ea0: 20 22 49 4e 46 4f 3a 20 74 65 73 74 20 22 20 74 "INFO: test " t
2eb0: 65 73 74 2d 69 64 20 22 20 61 63 74 75 61 6c 6c est-id " actuall
2ec0: 79 20 70 61 73 73 65 64 2c 20 73 6f 20 6d 61 72 y passed, so mar
2ed0: 6b 69 6e 67 20 50 41 53 53 20 6e 6f 74 20 44 45 king PASS not DE
2ee0: 41 44 22 29 0a 09 09 20 20 20 20 20 20 20 28 72 AD")... (r
2ef0: 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 mt:set-state-sta
2f00: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
2f10: 69 74 65 6d 73 0a 09 09 09 72 75 6e 2d 69 64 20 items....run-id
2f20: 74 65 73 74 2d 69 64 20 27 66 6f 6f 20 22 43 4f test-id 'foo "CO
2f30: 4d 50 4c 45 54 45 44 22 20 22 50 41 53 53 22 0a MPLETED" "PASS".
2f40: 09 09 09 22 54 65 73 74 20 73 74 6f 70 70 65 64 ..."Test stopped
2f50: 20 72 65 73 70 6f 6e 64 69 6e 67 20 62 75 74 20 responding but
2f60: 69 74 20 68 61 73 20 50 41 53 53 45 44 3b 20 6d it has PASSED; m
2f70: 61 72 6b 69 6e 67 20 69 74 20 50 41 53 53 20 69 arking it PASS i
2f80: 6e 20 74 68 65 20 44 42 2e 22 29 29 0a 09 09 20 n the DB."))...
2f90: 20 20 20 20 28 6c 65 74 20 28 28 69 73 2d 61 6c (let ((is-al
2fa0: 69 76 65 20 28 61 6e 64 20 28 6e 6f 74 20 28 65 ive (and (not (e
2fb0: 71 3f 20 70 69 64 20 30 29 29 20 20 3b 3b 20 30 q? pid 0)) ;; 0
2fc0: 20 69 73 20 64 65 66 61 75 6c 74 20 69 6e 20 72 is default in r
2fd0: 65 2d 75 73 65 64 20 66 69 65 6c 64 20 22 61 74 e-used field "at
2fe0: 74 65 6d 70 74 6e 75 6d 22 20 77 68 65 72 65 20 temptnum" where
2ff0: 70 69 64 20 73 74 6f 72 65 64 2e 0a 09 09 09 09 pid stored......
3000: 09 20 20 28 63 6f 6d 6d 6f 6e 6d 6f 64 3a 69 73 . (commonmod:is
3010: 2d 74 65 73 74 2d 61 6c 69 76 65 20 68 6f 73 74 -test-alive host
3020: 20 70 69 64 29 29 29 29 0a 09 09 20 20 20 20 20 pid))))...
3030: 20 20 28 69 66 20 69 73 2d 61 6c 69 76 65 0a 09 (if is-alive..
3040: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
3050: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3060: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 74 65 -port* "INFO: te
3070: 73 74 20 22 20 74 65 73 74 2d 69 64 20 22 20 6f st " test-id " o
3080: 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 0a 09 09 n host " host...
3090: 09 09 09 22 20 68 61 73 20 61 20 70 72 6f 63 65 ..." has a proce
30a0: 73 73 20 6f 6e 20 70 69 64 20 22 20 70 69 64 20 ss on pid " pid
30b0: 22 2c 20 4e 4f 54 20 73 65 74 74 69 6e 67 20 74 ", NOT setting t
30c0: 6f 20 44 45 41 44 2e 22 29 0a 09 09 09 20 20 20 o DEAD.")....
30d0: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 (begin.... (
30e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
30f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3100: 20 22 49 4e 46 4f 3a 20 74 65 73 74 20 22 20 74 "INFO: test " t
3110: 65 73 74 2d 69 64 0a 09 09 09 09 09 20 20 22 20 est-id...... "
3120: 66 69 6e 61 6c 20 73 74 61 74 65 2f 73 74 61 74 final state/stat
3130: 75 73 20 69 73 20 6e 6f 74 20 43 4f 4d 50 4c 45 us is not COMPLE
3140: 54 45 44 2f 50 41 53 53 2e 20 49 74 20 69 73 20 TED/PASS. It is
3150: 22 20 72 65 73 75 6c 74 29 0a 09 09 09 20 20 20 " result)....
3160: 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 (rmt:set-state
3170: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
3180: 2d 75 70 2d 69 74 65 6d 73 0a 09 09 09 20 20 20 -up-items....
3190: 20 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 run-id test-i
31a0: 64 20 27 66 6f 6f 20 22 43 4f 4d 50 4c 45 54 45 d 'foo "COMPLETE
31b0: 44 22 20 22 44 45 41 44 22 0a 09 09 09 20 20 20 D" "DEAD"....
31c0: 20 20 20 22 54 65 73 74 20 73 74 6f 70 70 65 64 "Test stopped
31d0: 20 72 65 73 70 6f 6e 64 69 6e 67 20 77 68 69 6c responding whil
31e0: 65 20 69 6e 20 52 55 4e 4e 49 4e 47 20 6f 72 20 e in RUNNING or
31f0: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 3b REMOTEHOSTSTART;
3200: 20 70 72 65 73 75 6d 65 64 20 64 65 61 64 2e 22 presumed dead."
3210: 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 3b 3b ))))))).. ;;
3220: 20 63 61 6c 6c 20 65 6e 64 20 6f 66 20 65 75 64 call end of eud
3230: 20 6f 66 20 72 75 6e 20 64 65 74 65 63 74 69 6f of run detectio
3240: 6e 20 66 6f 72 20 70 6f 73 74 68 6f 6f 6b 20 2d n for posthook -
3250: 20 66 72 6f 6d 20 6d 65 72 67 65 2c 20 69 73 20 from merge, is
3260: 69 74 20 6e 65 65 64 65 64 3f 0a 09 20 20 20 20 it needed?..
3270: 20 3b 3b 20 28 6c 61 75 6e 63 68 3a 65 6e 64 2d ;; (launch:end-
3280: 6f 66 2d 72 75 6e 2d 63 68 65 63 6b 20 72 75 6e of-run-check run
3290: 2d 69 64 29 0a 09 20 20 20 20 20 61 6c 6c 2d 69 -id).. all-i
32a0: 64 73 29 0a 09 20 20 20 20 29 29 29 29 29 0a 0a ds).. )))))..
32b0: 0a 29 0a .).