Artifact
700ce1d5a9dfd7ec1e1dbd8d09fba3f7622d17ae:
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 39 2c 20 4d 61 74 74 right 2019, 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 6d 74 6d 6f 64 29 29 0a 28 64 65 unit mtmod)).(de
03a0: 63 6c 61 72 65 20 28 75 73 65 73 20 6d 74 63 6f clare (uses mtco
03b0: 6e 66 69 67 66 29 29 0a 28 64 65 63 6c 61 72 65 nfigf)).(declare
03c0: 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 (uses commonmod
03d0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
03e0: 73 20 72 6d 74 6d 6f 64 29 29 0a 28 64 65 63 6c s rmtmod)).(decl
03f0: 61 72 65 20 28 75 73 65 73 20 74 65 73 74 73 6d are (uses testsm
0400: 6f 64 29 29 0a 0a 28 6d 6f 64 75 6c 65 20 6d 74 od))..(module mt
0410: 6d 6f 64 0a 09 2a 0a 09 0a 28 69 6d 70 6f 72 74 mod..*...(import
0420: 20 73 63 68 65 6d 65 20 63 68 69 63 6b 65 6e 20 scheme chicken
0430: 64 61 74 61 2d 73 74 72 75 63 74 75 72 65 73 20 data-structures
0440: 65 78 74 72 61 73 20 70 6f 73 69 78 29 0a 0a 28 extras posix)..(
0450: 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 6d import (prefix m
0460: 74 63 6f 6e 66 69 67 66 20 63 6f 6e 66 69 67 66 tconfigf configf
0470: 3a 29 0a 09 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 72 :)..commonmod..r
0480: 6d 74 6d 6f 64 0a 09 74 65 73 74 73 6d 6f 64 29 mtmod..testsmod)
0490: 0a 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 74 68 ...;; This is th
04a0: 65 20 4d 65 67 61 74 65 73 74 20 41 50 49 2e 20 e Megatest API.
04b0: 41 6c 6c 20 67 65 6e 65 72 61 6c 6c 79 20 22 75 All generally "u
04c0: 73 65 66 75 6c 22 20 72 6f 75 74 69 6e 65 73 20 seful" routines
04d0: 77 69 6c 6c 20 62 65 20 77 72 61 70 70 65 64 20 will be wrapped
04e0: 6f 72 20 65 78 74 65 6e 64 65 64 0a 3b 3b 20 68 or extended.;; h
04f0: 65 72 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ere...;;========
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
0540: 3b 20 20 52 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d ; R U N S.;;===
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0590: 3d 3d 3d 0a 0a 3b 3b 20 72 75 6e 73 3a 67 65 74 ===..;; runs:get
05a0: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 0a 3b 3b -runs-by-patt.;;
05b0: 20 67 65 74 20 72 75 6e 73 20 62 79 20 6c 69 73 get runs by lis
05c0: 74 20 6f 66 20 63 72 69 74 65 72 69 61 0a 3b 3b t of criteria.;;
05d0: 20 72 65 67 69 73 74 65 72 20 61 20 74 65 73 74 register a test
05e0: 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 run with the db
05f0: 0a 3b 3b 0a 3b 3b 20 55 73 65 3a 20 28 64 62 2d .;;.;; Use: (db-
0600: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
0610: 64 65 72 20 28 64 62 3a 67 65 74 2d 68 65 61 64 der (db:get-head
0620: 65 72 20 72 75 6e 69 6e 66 6f 29 28 64 62 3a 67 er runinfo)(db:g
0630: 65 74 2d 72 6f 77 73 20 72 75 6e 69 6e 66 6f 29 et-rows runinfo)
0640: 29 0a 3b 3b 20 20 74 6f 20 65 78 74 72 61 63 74 ).;; to extract
0650: 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 73 info from the s
0660: 74 72 75 63 74 75 72 65 20 72 65 74 75 72 6e 65 tructure returne
0670: 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 74 d.;;.(define (mt
0680: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
0690: 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 t keys runnamepa
06a0: 74 74 20 74 61 72 67 70 61 74 74 29 0a 20 20 28 tt targpatt). (
06b0: 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 73 64 let loop ((runsd
06c0: 61 74 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e at (rmt:get-run
06d0: 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 73 20 72 s-by-patt keys r
06e0: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 unnamepatt targp
06f0: 61 74 74 20 30 20 35 30 30 20 23 66 20 30 29 29 att 0 500 #f 0))
0700: 0a 09 20 20 20 20 20 28 72 65 73 20 20 20 20 20 .. (res
0710: 20 27 28 29 29 0a 09 20 20 20 20 20 28 6f 66 66 '()).. (off
0720: 73 65 74 20 20 20 30 29 0a 09 20 20 20 20 20 28 set 0).. (
0730: 6c 69 6d 69 74 20 20 20 20 35 30 30 29 29 0a 20 limit 500)).
0740: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 ;; (print "ru
0750: 6e 73 64 61 74 3a 20 22 20 72 75 6e 73 64 61 74 nsdat: " runsdat
0760: 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 68 65 ). (let* ((he
0770: 61 64 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d ader (vector-
0780: 72 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a ref runsdat 0)).
0790: 09 20 20 20 28 72 75 6e 73 6c 73 74 20 20 20 28 . (runslst (
07a0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 vector-ref runsd
07b0: 61 74 20 31 29 29 0a 09 20 20 20 28 66 75 6c 6c at 1)).. (full
07c0: 2d 6c 69 73 74 20 28 61 70 70 65 6e 64 20 72 65 -list (append re
07d0: 73 20 72 75 6e 73 6c 73 74 29 29 0a 09 20 20 20 s runslst))..
07e0: 28 68 61 76 65 2d 6d 6f 72 65 20 28 65 71 3f 20 (have-more (eq?
07f0: 28 6c 65 6e 67 74 68 20 72 75 6e 73 6c 73 74 29 (length runslst)
0800: 20 6c 69 6d 69 74 29 29 29 0a 20 20 20 20 20 20 limit))).
0810: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
0820: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
0830: 6f 72 74 2a 20 22 68 65 61 64 65 72 3a 20 22 20 ort* "header: "
0840: 68 65 61 64 65 72 20 22 20 72 75 6e 73 6c 73 74 header " runslst
0850: 3a 20 22 20 72 75 6e 73 6c 73 74 20 22 20 68 61 : " runslst " ha
0860: 76 65 2d 6d 6f 72 65 3a 20 22 20 68 61 76 65 2d ve-more: " have-
0870: 6d 6f 72 65 29 0a 20 20 20 20 20 20 28 69 66 20 more). (if
0880: 68 61 76 65 2d 6d 6f 72 65 20 0a 09 20 20 28 6c have-more .. (l
0890: 65 74 20 28 28 6e 65 77 2d 6f 66 66 73 65 74 20 et ((new-offset
08a0: 28 2b 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 29 (+ offset limit)
08b0: 29 0a 09 09 28 6e 65 78 74 2d 62 61 74 63 68 20 )...(next-batch
08c0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (rmt:get-runs-by
08d0: 2d 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 -patt keys runna
08e0: 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 mepatt targpatt
08f0: 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 23 66 20 offset limit #f
0900: 30 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 0))).. (debug
0910: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
0920: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0930: 20 22 4d 6f 72 65 20 74 68 61 6e 20 22 20 6c 69 "More than " li
0940: 6d 69 74 20 22 20 72 75 6e 73 2c 20 68 61 76 65 mit " runs, have
0950: 20 22 20 28 6c 65 6e 67 74 68 20 66 75 6c 6c 2d " (length full-
0960: 6c 69 73 74 29 20 22 20 72 75 6e 73 20 73 6f 20 list) " runs so
0970: 66 61 72 2e 22 29 0a 09 20 20 20 20 28 64 65 62 far.").. (deb
0980: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
0990: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
09a0: 74 2a 20 22 6e 65 78 74 2d 62 61 74 63 68 3a 20 t* "next-batch:
09b0: 22 20 6e 65 78 74 2d 62 61 74 63 68 29 0a 09 20 " next-batch)..
09c0: 20 20 20 28 6c 6f 6f 70 20 6e 65 78 74 2d 62 61 (loop next-ba
09d0: 74 63 68 0a 09 09 20 20 66 75 6c 6c 2d 6c 69 73 tch... full-lis
09e0: 74 0a 09 09 20 20 6e 65 77 2d 6f 66 66 73 65 74 t... new-offset
09f0: 0a 09 09 20 20 6c 69 6d 69 74 29 29 0a 09 20 28 ... limit)).. (
0a00: 76 65 63 74 6f 72 20 68 65 61 64 65 72 20 66 75 vector header fu
0a10: 6c 6c 2d 6c 69 73 74 29 29 29 29 29 0a 0a 3b 3b ll-list)))))..;;
0a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a60: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 ======.;; T E S
0a70: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;=========
0a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
0ac0: 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 2d 74 define (mt:get-t
0ad0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e ests-for-run run
0ae0: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
0af0: 74 65 73 20 73 74 61 74 75 73 20 23 21 6b 65 79 tes status #!key
0b00: 20 28 6e 6f 74 2d 69 6e 20 23 74 29 20 28 73 6f (not-in #t) (so
0b10: 72 74 2d 62 79 20 27 65 76 65 6e 74 5f 74 69 6d rt-by 'event_tim
0b20: 65 29 20 28 73 6f 72 74 2d 6f 72 64 65 72 20 22 e) (sort-order "
0b30: 41 53 43 22 29 20 28 71 72 79 76 61 6c 73 20 23 ASC") (qryvals #
0b40: 66 29 28 6c 61 73 74 2d 75 70 64 61 74 65 20 23 f)(last-update #
0b50: 66 29 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 f)). (let loop
0b60: 28 28 74 65 73 74 73 64 61 74 20 28 72 6d 74 3a ((testsdat (rmt:
0b70: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
0b80: 6e 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 n run-id testpat
0b90: 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 t states status
0ba0: 30 20 35 30 30 20 6e 6f 74 2d 69 6e 20 73 6f 72 0 500 not-in sor
0bb0: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
0bc0: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
0bd0: 61 74 65 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 20 ate 'normal))..
0be0: 20 20 20 20 28 72 65 73 20 20 20 20 20 20 27 28 (res '(
0bf0: 29 29 0a 09 20 20 20 20 20 28 6f 66 66 73 65 74 )).. (offset
0c00: 20 20 20 30 29 0a 09 20 20 20 20 20 28 6c 69 6d 0).. (lim
0c10: 69 74 20 20 20 20 35 30 30 29 29 0a 20 20 20 20 it 500)).
0c20: 28 6c 65 74 2a 20 28 28 66 75 6c 6c 2d 6c 69 73 (let* ((full-lis
0c30: 74 20 28 61 70 70 65 6e 64 20 72 65 73 20 74 65 t (append res te
0c40: 73 74 73 64 61 74 29 29 0a 09 20 20 20 28 68 61 stsdat)).. (ha
0c50: 76 65 2d 6d 6f 72 65 20 28 65 71 3f 20 28 6c 65 ve-more (eq? (le
0c60: 6e 67 74 68 20 74 65 73 74 73 64 61 74 29 20 6c ngth testsdat) l
0c70: 69 6d 69 74 29 29 29 0a 20 20 20 20 20 20 28 69 imit))). (i
0c80: 66 20 68 61 76 65 2d 6d 6f 72 65 20 0a 09 20 20 f have-more ..
0c90: 28 6c 65 74 20 28 28 6e 65 77 2d 6f 66 66 73 65 (let ((new-offse
0ca0: 74 20 28 2b 20 6f 66 66 73 65 74 20 6c 69 6d 69 t (+ offset limi
0cb0: 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 t))).. (debug
0cc0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
0cd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0ce0: 20 22 4d 6f 72 65 20 74 68 61 6e 20 22 20 6c 69 "More than " li
0cf0: 6d 69 74 20 22 20 74 65 73 74 73 2c 20 68 61 76 mit " tests, hav
0d00: 65 20 22 20 28 6c 65 6e 67 74 68 20 66 75 6c 6c e " (length full
0d10: 2d 6c 69 73 74 29 20 22 20 74 65 73 74 73 20 73 -list) " tests s
0d20: 6f 20 66 61 72 2e 22 29 0a 09 20 20 20 20 28 6c o far.").. (l
0d30: 6f 6f 70 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 oop (rmt:get-tes
0d40: 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 ts-for-run run-i
0d50: 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 d testpatt state
0d60: 73 20 73 74 61 74 75 73 20 6e 65 77 2d 6f 66 66 s status new-off
0d70: 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e set limit not-in
0d80: 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 sort-by sort-or
0d90: 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 74 der qryvals last
0da0: 2d 75 70 64 61 74 65 20 27 6e 6f 72 6d 61 6c 29 -update 'normal)
0db0: 0a 09 09 20 20 66 75 6c 6c 2d 6c 69 73 74 0a 09 ... full-list..
0dc0: 09 20 20 6e 65 77 2d 6f 66 66 73 65 74 0a 09 09 . new-offset...
0dd0: 20 20 6c 69 6d 69 74 29 29 0a 09 20 20 66 75 6c limit)).. ful
0de0: 6c 2d 6c 69 73 74 29 29 29 29 0a 0a 28 64 65 66 l-list))))..(def
0df0: 69 6e 65 20 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 ine (mt:lazy-get
0e00: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
0e10: 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 run-id waitons
0e20: 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 ref-item-path #!
0e30: 6b 65 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 6d key (mode '(norm
0e40: 61 6c 29 29 28 69 74 65 6d 6d 61 70 73 20 23 66 al))(itemmaps #f
0e50: 29 20 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 ) ). (let* ((ke
0e60: 79 20 20 20 20 28 6c 69 73 74 20 72 75 6e 2d 69 y (list run-i
0e70: 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 69 74 d waitons ref-it
0e80: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 29 29 0a 09 em-path mode))..
0e90: 20 28 72 65 73 20 20 20 20 28 68 61 73 68 2d 74 (res (hash-t
0ea0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
0eb0: 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 *pre-reqs-met-c
0ec0: 61 63 68 65 2a 20 6b 65 79 20 23 66 29 29 0a 09 ache* key #f))..
0ed0: 20 28 75 73 65 72 65 73 20 28 6c 65 74 20 28 28 (useres (let ((
0ee0: 6c 61 73 74 2d 74 69 6d 65 20 28 69 66 20 28 76 last-time (if (v
0ef0: 65 63 74 6f 72 3f 20 72 65 73 29 20 28 76 65 63 ector? res) (vec
0f00: 74 6f 72 2d 72 65 66 20 72 65 73 20 30 29 20 23 tor-ref res 0) #
0f10: 66 29 29 29 0a 09 09 20 20 20 28 69 66 20 6c 61 f)))... (if la
0f20: 73 74 2d 74 69 6d 65 0a 09 09 20 20 20 20 20 20 st-time...
0f30: 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (< (current-sec
0f40: 6f 6e 64 73 29 28 2b 20 6c 61 73 74 2d 74 69 6d onds)(+ last-tim
0f50: 65 20 35 29 29 0a 09 09 20 20 20 20 20 20 20 23 e 5))... #
0f60: 66 29 29 29 29 0a 20 20 20 20 28 69 66 20 75 73 f)))). (if us
0f70: 65 72 65 73 0a 09 28 6c 65 74 20 28 28 72 65 73 eres..(let ((res
0f80: 75 6c 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ult (vector-ref
0f90: 72 65 73 20 31 29 29 29 0a 09 20 20 28 64 65 62 res 1))).. (deb
0fa0: 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 ug:print 4 *defa
0fb0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 ult-log-port* "U
0fc0: 73 69 6e 67 20 6c 61 7a 79 20 76 61 6c 75 65 20 sing lazy value
0fd0: 72 65 73 3a 20 22 20 72 65 73 75 6c 74 29 0a 09 res: " result)..
0fe0: 20 20 72 65 73 75 6c 74 29 0a 09 28 6c 65 74 20 result)..(let
0ff0: 28 28 6e 65 77 72 65 73 20 28 72 6d 74 3a 67 65 ((newres (rmt:ge
1000: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
1010: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
1020: 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 6d ref-item-path m
1030: 6f 64 65 3a 20 6d 6f 64 65 20 69 74 65 6d 6d 61 ode: mode itemma
1040: 70 73 3a 20 69 74 65 6d 6d 61 70 73 29 29 29 0a ps: itemmaps))).
1050: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
1060: 65 74 21 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 et! *pre-reqs-me
1070: 74 2d 63 61 63 68 65 2a 20 6b 65 79 20 28 76 65 t-cache* key (ve
1080: 63 74 6f 72 20 28 63 75 72 72 65 6e 74 2d 73 65 ctor (current-se
1090: 63 6f 6e 64 73 29 20 6e 65 77 72 65 73 29 29 0a conds) newres)).
10a0: 09 20 20 6e 65 77 72 65 73 29 29 29 29 0a 0a 28 . newres))))..(
10b0: 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 2d 72 define (mt:get-r
10c0: 75 6e 2d 73 74 61 74 73 20 64 62 73 74 72 75 63 un-stats dbstruc
10d0: 74 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 47 65 t run-id).;; Ge
10e0: 74 20 72 75 6e 20 73 74 61 74 73 20 66 72 6f 6d t run stats from
10f0: 20 6c 6f 63 61 6c 20 61 63 63 65 73 73 2c 20 6d local access, m
1100: 6f 76 65 20 74 68 69 73 20 2e 2e 2e 20 62 75 74 ove this ... but
1110: 20 77 68 65 72 65 3f 0a 20 20 28 64 62 3a 67 65 where?. (db:ge
1120: 74 2d 72 75 6e 2d 73 74 61 74 73 20 64 62 73 74 t-run-stats dbst
1130: 72 75 63 74 20 72 75 6e 2d 69 64 29 29 0a 0a 28 ruct run-id))..(
1140: 64 65 66 69 6e 65 20 28 6d 74 3a 64 69 73 63 61 define (mt:disca
1150: 72 64 2d 62 6c 6f 63 6b 65 64 2d 74 65 73 74 73 rd-blocked-tests
1160: 20 72 75 6e 2d 69 64 20 66 61 69 6c 65 64 2d 74 run-id failed-t
1170: 65 73 74 20 74 65 73 74 73 20 74 65 73 74 2d 72 est tests test-r
1180: 65 63 6f 72 64 73 29 0a 20 20 28 69 66 20 28 6e ecords). (if (n
1190: 75 6c 6c 3f 20 74 65 73 74 73 29 0a 20 20 20 20 ull? tests).
11a0: 20 20 74 65 73 74 73 0a 20 20 20 20 20 20 28 62 tests. (b
11b0: 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 egin..(debug:pri
11c0: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
11d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 69 lt-log-port* "Di
11e0: 73 63 61 72 64 69 6e 67 20 74 65 73 74 73 20 66 scarding tests f
11f0: 72 6f 6d 20 22 20 74 65 73 74 73 20 22 20 74 68 rom " tests " th
1200: 61 74 20 61 72 65 20 77 61 69 74 69 6e 67 20 6f at are waiting o
1210: 6e 20 22 20 66 61 69 6c 65 64 2d 74 65 73 74 29 n " failed-test)
1220: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 ..(let loop ((te
1230: 73 74 6e 20 28 63 61 72 20 74 65 73 74 73 29 29 stn (car tests))
1240: 0a 09 09 20 20 20 28 72 65 6d 74 20 20 28 63 64 ... (remt (cd
1250: 72 20 74 65 73 74 73 29 29 0a 09 09 20 20 20 28 r tests))... (
1260: 72 65 73 20 20 20 27 28 29 29 29 0a 09 20 20 28 res '())).. (
1270: 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 let* ((test-dat
1280: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1290: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 default test-rec
12a0: 6f 72 64 73 20 74 65 73 74 6e 20 28 76 65 63 74 ords testn (vect
12b0: 6f 72 20 23 66 20 23 66 20 27 28 29 29 29 29 0a or #f #f '()))).
12c0: 09 09 20 28 77 61 69 74 6f 6e 73 20 20 28 76 65 .. (waitons (ve
12d0: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 2d 64 61 ctor-ref test-da
12e0: 74 20 32 29 29 29 0a 09 20 20 20 20 3b 3b 20 28 t 2))).. ;; (
12f0: 70 72 69 6e 74 20 22 6d 74 3a 64 69 73 63 61 72 print "mt:discar
1300: 64 2d 62 6c 6f 63 6b 65 64 2d 74 65 73 74 73 20 d-blocked-tests
1310: 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 run-id: " run-id
1320: 20 22 20 66 61 69 6c 65 64 2d 74 65 73 74 3a 20 " failed-test:
1330: 22 20 66 61 69 6c 65 64 2d 74 65 73 74 20 22 20 " failed-test "
1340: 74 65 73 74 6e 3a 20 22 20 74 65 73 74 6e 20 22 testn: " testn "
1350: 20 77 69 74 68 20 77 61 69 74 6f 6e 73 3a 20 22 with waitons: "
1360: 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 waitons).. (
1370: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 29 0a if (null? remt).
1380: 09 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 65 73 ..(let ((new-res
1390: 20 28 72 65 76 65 72 73 65 20 72 65 73 29 29 29 (reverse res)))
13a0: 0a 09 09 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ... ;; (print "
13b0: 20 20 20 20 20 20 20 6e 65 77 2d 72 65 73 3a 20 new-res:
13c0: 22 20 6e 65 77 2d 72 65 73 29 0a 09 09 20 20 6e " new-res)... n
13d0: 65 77 2d 72 65 73 29 0a 09 09 28 6c 6f 6f 70 20 ew-res)...(loop
13e0: 28 63 61 72 20 72 65 6d 74 29 0a 09 09 20 20 20 (car remt)...
13f0: 20 20 20 28 63 64 72 20 72 65 6d 74 29 0a 09 09 (cdr remt)...
1400: 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 (if (membe
1410: 72 20 66 61 69 6c 65 64 2d 74 65 73 74 20 77 61 r failed-test wa
1420: 69 74 6f 6e 73 29 0a 09 09 09 20 20 28 62 65 67 itons).... (beg
1430: 69 6e 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 in.... (debug
1440: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1450: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 69 73 t-log-port* "Dis
1460: 63 61 72 64 69 6e 67 20 74 65 73 74 20 22 20 74 carding test " t
1470: 65 73 74 6e 20 22 28 22 20 74 65 73 74 2d 64 61 estn "(" test-da
1480: 74 20 22 29 20 64 75 65 20 74 6f 20 22 20 66 61 t ") due to " fa
1490: 69 6c 65 64 2d 74 65 73 74 29 0a 09 09 09 20 20 iled-test)....
14a0: 20 20 72 65 73 29 0a 09 09 09 20 20 28 63 6f 6e res).... (con
14b0: 73 20 74 65 73 74 6e 20 72 65 73 29 29 29 29 29 s testn res)))))
14c0: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
14d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
1510: 3b 20 20 53 20 54 20 41 20 54 20 45 20 20 20 41 ; S T A T E A
1520: 20 4e 20 44 20 20 20 53 20 54 20 41 20 54 20 55 N D S T A T U
1530: 20 53 20 20 20 46 20 4f 20 52 20 20 20 54 20 45 S F O R T E
1540: 20 53 20 54 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d S T S .;;======
1550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1590: 0a 0a 3b 3b 20 73 70 65 65 64 20 75 70 20 66 6f ..;; speed up fo
15a0: 72 20 63 6f 6d 6d 6f 6e 20 63 61 73 65 73 20 77 r common cases w
15b0: 69 74 68 20 61 20 6c 69 74 74 6c 65 20 6c 6f 67 ith a little log
15c0: 69 63 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a 74 ic.(define (mt:t
15d0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
15e0: 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 atus-by-id run-i
15f0: 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 d test-id newsta
1600: 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 te newstatus new
1610: 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 69 66 20 28 comment). (if (
1620: 6e 6f 74 20 28 61 6e 64 20 72 75 6e 2d 69 64 20 not (and run-id
1630: 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 test-id)).
1640: 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 (begin..(debug:p
1650: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1660: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1670: 22 62 61 64 20 64 61 74 61 20 68 61 6e 64 65 64 "bad data handed
1680: 20 74 6f 20 6d 74 3a 74 65 73 74 2d 73 65 74 2d to mt:test-set-
1690: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
16a0: 69 64 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e id, run-id=" run
16b0: 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 64 3d 22 -id ", test-id="
16c0: 20 74 65 73 74 2d 69 64 20 22 2c 20 6e 65 77 73 test-id ", news
16d0: 74 61 74 65 3d 22 20 6e 65 77 73 74 61 74 65 29 tate=" newstate)
16e0: 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 ..(print-call-ch
16f0: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
1700: 6f 72 2d 70 6f 72 74 29 29 0a 09 23 66 29 0a 20 or-port))..#f).
1710: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 3b 3b 20 (begin..;;
1720: 63 6f 6e 64 0a 09 3b 3b 20 28 28 61 6e 64 20 6e cond..;; ((and n
1730: 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 ewstate newstatu
1740: 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 09 3b s newcomment)..;
1750: 3b 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d ; (rmt:general-
1760: 63 61 6c 6c 20 27 73 74 61 74 65 2d 73 74 61 74 call 'state-stat
1770: 75 73 2d 6d 73 67 20 72 75 6e 2d 69 64 20 6e 65 us-msg run-id ne
1780: 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 wstate newstatus
1790: 20 6e 65 77 63 6f 6d 6d 65 6e 74 20 74 65 73 74 newcomment test
17a0: 2d 69 64 29 29 0a 09 3b 3b 20 28 28 61 6e 64 20 -id))..;; ((and
17b0: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
17c0: 75 73 29 0a 09 3b 3b 20 20 28 72 6d 74 3a 67 65 us)..;; (rmt:ge
17d0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 74 61 74 neral-call 'stat
17e0: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
17f0: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
1800: 75 73 20 74 65 73 74 2d 69 64 29 29 0a 09 3b 3b us test-id))..;;
1810: 20 28 65 6c 73 65 0a 09 3b 3b 20 20 28 69 66 20 (else..;; (if
1820: 6e 65 77 73 74 61 74 65 20 20 20 28 72 6d 74 3a newstate (rmt:
1830: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 general-call 'se
1840: 74 2d 74 65 73 74 2d 73 74 61 74 65 20 20 20 72 t-test-state r
1850: 75 6e 2d 69 64 20 6e 65 77 73 74 61 74 65 20 20 un-id newstate
1860: 20 74 65 73 74 2d 69 64 29 29 0a 09 3b 3b 20 20 test-id))..;;
1870: 28 69 66 20 6e 65 77 73 74 61 74 75 73 20 20 28 (if newstatus (
1880: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
1890: 20 27 73 65 74 2d 74 65 73 74 2d 73 74 61 74 75 'set-test-statu
18a0: 73 20 20 72 75 6e 2d 69 64 20 6e 65 77 73 74 61 s run-id newsta
18b0: 74 75 73 20 20 74 65 73 74 2d 69 64 29 29 0a 09 tus test-id))..
18c0: 3b 3b 20 20 28 69 66 20 6e 65 77 63 6f 6d 6d 65 ;; (if newcomme
18d0: 6e 74 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d nt (rmt:general-
18e0: 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 2d 63 call 'set-test-c
18f0: 6f 6d 6d 65 6e 74 20 72 75 6e 2d 69 64 20 6e 65 omment run-id ne
1900: 77 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d 69 64 wcomment test-id
1910: 29 29 29 29 0a 09 28 72 6d 74 3a 73 65 74 2d 73 ))))..(rmt:set-s
1920: 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d tate-status-and-
1930: 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 roll-up-items ru
1940: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 23 66 20 n-id test-id #f
1950: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
1960: 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 09 us newcomment)..
1970: 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d 74 ;; (mt:process-t
1980: 72 69 67 67 65 72 73 20 72 75 6e 2d 69 64 20 74 riggers run-id t
1990: 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 est-id newstate
19a0: 6e 65 77 73 74 61 74 75 73 29 0a 09 23 74 29 29 newstatus)..#t))
19b0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a )...(define (mt:
19c0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
19d0: 74 61 74 75 73 2d 62 79 2d 69 64 2d 75 6e 6c 65 tatus-by-id-unle
19e0: 73 73 2d 63 6f 6d 70 6c 65 74 65 64 20 72 75 6e ss-completed run
19f0: 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 -id test-id news
1a00: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e tate newstatus n
1a10: 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 6c 65 ewcomment). (le
1a20: 74 2a 20 28 28 74 65 73 74 2d 76 65 63 20 20 20 t* ((test-vec
1a30: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 (rmt:get-testinf
1a40: 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 o-state-status r
1a50: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a un-id test-id)).
1a60: 20 20 20 20 20 20 20 20 20 28 73 74 61 74 65 20 (state
1a70: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
1a80: 74 65 73 74 2d 76 65 63 20 33 29 29 29 0a 20 20 test-vec 3))).
1a90: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 74 (if (equal? st
1aa0: 61 74 65 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 ate "COMPLETED")
1ab0: 0a 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 . #t.
1ac0: 20 20 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 (rmt:set-sta
1ad0: 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f te-status-and-ro
1ae0: 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d ll-up-items run-
1af0: 69 64 20 74 65 73 74 2d 69 64 20 23 66 20 6e 65 id test-id #f ne
1b00: 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 wstate newstatus
1b10: 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 29 29 29 0a newcomment)))).
1b20: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a . .(define (mt:
1b30: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
1b40: 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 6d tatus-by-testnam
1b50: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 e run-id test-na
1b60: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 6e 65 77 me item-path new
1b70: 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 61 74 75 -state new-statu
1b80: 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 29 0a 20 s new-comment).
1b90: 20 3b 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 ;(let ((test-id
1ba0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
1bb0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
1bc0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
1bd0: 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 (rmt:set-state
1be0: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
1bf0: 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 -up-items run-id
1c00: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
1c10: 70 61 74 68 20 6e 65 77 2d 73 74 61 74 65 20 6e path new-state n
1c20: 65 77 2d 73 74 61 74 75 73 20 6e 65 77 2d 63 6f ew-status new-co
1c30: 6d 6d 65 6e 74 29 0a 20 20 3b 3b 20 28 6d 74 3a mment). ;; (mt:
1c40: 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 process-triggers
1c50: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
1c60: 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 new-state new-st
1c70: 61 74 75 73 29 0a 20 20 23 74 29 3b 29 0a 09 3b atus). #t);)..;
1c80: 3b 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 ;(mt:test-set-st
1c90: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
1ca0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
1cb0: 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 new-state new-st
1cc0: 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 atus new-comment
1cd0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 74 )))..(define (mt
1ce0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
1cf0: 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 status-by-testna
1d00: 6d 65 2d 75 6e 6c 65 73 73 2d 63 6f 6d 70 6c 65 me-unless-comple
1d10: 74 65 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ted run-id test-
1d20: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 6e name item-path n
1d30: 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 61 ew-state new-sta
1d40: 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 29 tus new-comment)
1d50: 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 . (let ((test-i
1d60: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
1d70: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
1d80: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
1d90: 0a 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 65 . (mt:test-se
1da0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
1db0: 79 2d 69 64 2d 75 6e 6c 65 73 73 2d 63 6f 6d 70 y-id-unless-comp
1dc0: 6c 65 74 65 64 20 72 75 6e 2d 69 64 20 74 65 73 leted run-id tes
1dd0: 74 2d 69 64 20 6e 65 77 2d 73 74 61 74 65 20 6e t-id new-state n
1de0: 65 77 2d 73 74 61 74 75 73 20 6e 65 77 2d 63 6f ew-status new-co
1df0: 6d 6d 65 6e 74 29 29 29 0a 20 20 20 20 0a 3b 3b mment))). .;;
1e00: 20 6b 69 6c 6c 20 61 6e 79 20 72 75 6e 6e 65 72 kill any runner
1e10: 20 70 72 6f 63 65 73 73 65 73 20 28 69 2e 65 2e processes (i.e.
1e20: 20 70 72 6f 63 65 73 73 65 73 20 68 61 6e 64 6c processes handl
1e30: 69 6e 67 20 2d 72 75 6e 74 65 73 74 73 29 20 74 ing -runtests) t
1e40: 68 61 74 20 6d 61 74 63 68 20 74 61 72 67 65 74 hat match target
1e50: 2f 72 75 6e 6e 61 6d 65 0a 3b 3b 20 0a 3b 3b 20 /runname.;; .;;
1e60: 64 6f 20 61 20 72 65 6d 6f 74 65 20 63 61 6c 6c do a remote call
1e70: 20 74 6f 20 67 65 74 20 74 68 65 20 74 61 73 6b to get the task
1e80: 20 71 75 65 75 65 20 69 6e 66 6f 20 62 75 74 20 queue info but
1e90: 64 6f 20 74 68 65 20 6b 69 6c 6c 69 6e 67 20 61 do the killing a
1ea0: 73 20 73 65 6c 66 20 68 65 72 65 2e 0a 3b 3b 0a s self here..;;.
1eb0: 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 6b (define (tasks:k
1ec0: 69 6c 6c 2d 72 75 6e 6e 65 72 20 74 61 72 67 65 ill-runner targe
1ed0: 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 70 t run-name testp
1ee0: 61 74 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 att). (let ((re
1ef0: 63 6f 72 64 73 20 20 20 20 28 72 6d 74 3a 74 61 cords (rmt:ta
1f00: 73 6b 73 2d 66 69 6e 64 2d 74 61 73 6b 2d 71 75 sks-find-task-qu
1f10: 65 75 65 2d 72 65 63 6f 72 64 73 20 74 61 72 67 eue-records targ
1f20: 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 et run-name test
1f30: 70 61 74 74 20 22 72 75 6e 6e 69 6e 67 22 20 22 patt "running" "
1f40: 72 75 6e 2d 74 65 73 74 73 22 29 29 0a 09 28 68 run-tests"))..(h
1f50: 6f 73 74 70 69 64 2d 72 78 20 28 72 65 67 65 78 ostpid-rx (regex
1f60: 70 20 22 5c 5c 73 2b 28 5c 5c 77 2b 29 5c 5c 73 p "\\s+(\\w+)\\s
1f70: 2b 28 5c 5c 64 2b 29 24 22 29 29 29 20 3b 3b 20 +(\\d+)$"))) ;;
1f80: 68 6f 73 74 20 70 69 64 20 69 73 20 61 74 20 65 host pid is at e
1f90: 6e 64 20 6f 66 20 70 61 72 61 6d 20 73 74 72 69 nd of param stri
1fa0: 6e 67 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ng. (if (null
1fb0: 3f 20 72 65 63 6f 72 64 73 29 0a 09 28 64 65 62 ? records)..(deb
1fc0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
1fd0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e ult-log-port* "N
1fe0: 6f 20 72 75 6e 20 6c 61 75 6e 63 68 69 6e 67 20 o run launching
1ff0: 70 72 6f 63 65 73 73 65 73 20 66 6f 75 6e 64 20 processes found
2000: 66 6f 72 20 22 20 74 61 72 67 65 74 20 22 20 2f for " target " /
2010: 20 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 77 69 " run-name " wi
2020: 74 68 20 74 65 73 74 70 61 74 74 20 22 20 28 6f th testpatt " (o
2030: 72 20 74 65 73 74 70 61 74 74 20 22 2a 20 6e 6f r testpatt "* no
2040: 20 74 65 73 74 70 61 74 74 20 73 70 65 63 69 66 testpatt specif
2050: 69 65 64 21 20 2a 22 29 29 0a 09 28 64 65 62 75 ied! *"))..(debu
2060: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
2070: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 6f lt-log-port* "Fo
2080: 75 6e 64 20 22 20 28 6c 65 6e 67 74 68 20 72 65 und " (length re
2090: 63 6f 72 64 73 29 20 22 20 72 75 6e 28 73 29 20 cords) " run(s)
20a0: 74 6f 20 6b 69 6c 6c 2e 22 29 29 0a 20 20 20 20 to kill.")).
20b0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
20c0: 28 6c 61 6d 62 64 61 20 28 72 65 63 6f 72 64 29 (lambda (record)
20d0: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
20e0: 70 61 72 61 6d 2d 6b 65 79 20 28 6c 69 73 74 2d param-key (list-
20f0: 72 65 66 20 72 65 63 6f 72 64 20 38 29 29 0a 09 ref record 8))..
2100: 20 20 20 20 20 20 28 6d 61 74 63 68 2d 64 61 74 (match-dat
2110: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
2120: 68 6f 73 74 70 69 64 2d 72 78 20 70 61 72 61 6d hostpid-rx param
2130: 2d 6b 65 79 29 29 29 0a 09 20 28 69 66 20 6d 61 -key))).. (if ma
2140: 74 63 68 2d 64 61 74 0a 09 20 20 20 20 20 28 6c tch-dat.. (l
2150: 65 74 20 28 28 68 6f 73 74 6e 61 6d 65 20 20 28 et ((hostname (
2160: 63 61 64 72 20 6d 61 74 63 68 2d 64 61 74 29 29 cadr match-dat))
2170: 0a 09 09 20 20 20 28 70 69 64 20 20 20 20 20 20 ... (pid
2180: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
2190: 20 28 63 61 64 64 72 20 6d 61 74 63 68 2d 64 61 (caddr match-da
21a0: 74 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 64 t)))).. (d
21b0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
21c0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
21d0: 22 53 65 6e 64 69 6e 67 20 53 49 47 49 4e 54 20 "Sending SIGINT
21e0: 74 6f 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 to process " pid
21f0: 20 22 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 " on host " hos
2200: 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 28 tname).. (
2210: 69 66 20 28 65 71 75 61 6c 3f 20 28 67 65 74 2d if (equal? (get-
2220: 68 6f 73 74 2d 6e 61 6d 65 29 20 68 6f 73 74 6e host-name) hostn
2230: 61 6d 65 29 0a 09 09 20 20 20 28 69 66 20 28 70 ame)... (if (p
2240: 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 70 69 rocess:alive? pi
2250: 64 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 d)... (beg
2260: 69 6e 0a 09 09 09 20 28 68 61 6e 64 6c 65 2d 65 in.... (handle-e
2270: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 65 xceptions.... e
2280: 78 6e 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 xn.... (begin..
2290: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
22a0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
22b0: 67 2d 70 6f 72 74 2a 20 22 4b 69 6c 6c 20 6f 66 g-port* "Kill of
22c0: 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 20 22 process " pid "
22d0: 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 6e on host " hostn
22e0: 61 6d 65 20 22 20 66 61 69 6c 65 64 2e 22 29 0a ame " failed.").
22f0: 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
2300: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2310: 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 og-port* " messa
2320: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
2330: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
2340: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
2350: 65 29 20 65 78 6e 29 29 0a 09 09 09 20 20 20 20 e) exn))....
2360: 23 74 29 0a 09 09 09 20 20 28 70 72 6f 63 65 73 #t).... (proces
2370: 73 2d 73 69 67 6e 61 6c 20 70 69 64 20 73 69 67 s-signal pid sig
2380: 6e 61 6c 2f 69 6e 74 29 0a 09 09 09 20 20 28 74 nal/int).... (t
2390: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a hread-sleep! 5).
23a0: 09 09 09 20 20 28 69 66 20 28 70 72 6f 63 65 73 ... (if (proces
23b0: 73 3a 61 6c 69 76 65 3f 20 70 69 64 29 0a 09 09 s:alive? pid)...
23c0: 09 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d . (process-
23d0: 73 69 67 6e 61 6c 20 70 69 64 20 73 69 67 6e 61 signal pid signa
23e0: 6c 2f 6b 69 6c 6c 29 29 29 29 29 0a 09 09 20 20 l/kill)))))...
23f0: 20 3b 3b 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d ;; (call-with-
2400: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
2410: 61 62 6c 65 73 0a 09 09 20 20 20 28 6c 65 74 20 ables... (let
2420: 28 28 6f 6c 64 2d 74 61 72 67 65 74 68 6f 73 74 ((old-targethost
2430: 20 28 67 65 74 65 6e 76 20 22 54 41 52 47 45 54 (getenv "TARGET
2440: 48 4f 53 54 22 29 29 29 0a 09 09 20 20 20 20 20 HOST")))...
2450: 28 73 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 (setenv "TARGETH
2460: 4f 53 54 22 20 68 6f 73 74 6e 61 6d 65 29 0a 09 OST" hostname)..
2470: 09 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 54 . (setenv "T
2480: 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 20 ARGETHOST_LOGF"
2490: 22 73 65 72 76 65 72 2d 6b 69 6c 6c 73 2e 6c 6f "server-kills.lo
24a0: 67 22 29 0a 09 09 20 20 20 20 20 28 73 79 73 74 g")... (syst
24b0: 65 6d 20 28 63 6f 6e 63 20 22 6e 62 66 61 6b 65 em (conc "nbfake
24c0: 20 6b 69 6c 6c 20 22 20 70 69 64 29 29 0a 09 09 kill " pid))...
24d0: 20 20 20 20 20 28 69 66 20 6f 6c 64 2d 74 61 72 (if old-tar
24e0: 67 65 74 68 6f 73 74 20 28 73 65 74 65 6e 76 20 gethost (setenv
24f0: 22 54 41 52 47 45 54 48 4f 53 54 22 20 6f 6c 64 "TARGETHOST" old
2500: 2d 74 61 72 67 65 74 68 6f 73 74 29 29 0a 09 09 -targethost))...
2510: 20 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 (unsetenv "
2520: 54 41 52 47 45 54 48 4f 53 54 22 29 0a 09 09 20 TARGETHOST")...
2530: 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 22 54 (unsetenv "T
2540: 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 29 ARGETHOST_LOGF")
2550: 29 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 ))).. (debug
2560: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
2570: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2580: 2a 20 22 6e 6f 20 72 65 63 6f 72 64 20 6f 72 20 * "no record or
2590: 69 6d 70 72 6f 70 65 72 20 72 65 63 6f 72 64 20 improper record
25a0: 66 6f 72 20 22 20 74 61 72 67 65 74 20 22 2f 22 for " target "/"
25b0: 20 72 75 6e 2d 6e 61 6d 65 20 22 20 69 6e 20 74 run-name " in t
25c0: 61 73 6b 73 5f 71 75 65 75 65 20 69 6e 20 6d 61 asks_queue in ma
25d0: 69 6e 2e 64 62 22 29 29 29 29 0a 20 20 20 20 20 in.db")))).
25e0: 72 65 63 6f 72 64 73 29 29 29 0a 0a 28 64 65 66 records)))..(def
25f0: 69 6e 65 20 28 74 61 73 6b 3a 67 65 74 2d 72 75 ine (task:get-ru
2600: 6e 2d 74 69 6d 65 73 29 0a 20 20 20 28 6c 65 74 n-times). (let
2610: 2a 20 28 20 0a 20 20 20 20 20 20 20 20 20 20 20 * ( .
2620: 28 72 75 6e 2d 70 61 74 74 20 28 69 66 20 28 61 (run-patt (if (a
2630: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
2640: 6e 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 n-patt").
2650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2660: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
2670: 2d 72 75 6e 2d 70 61 74 74 22 29 0a 20 20 20 20 -run-patt").
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2690: 20 20 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 "%")).
26a0: 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 (target-pat
26b0: 74 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d t (if (args:get-
26c0: 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 74 arg "-target-pat
26d0: 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t").
26e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 (arg
26f0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
2700: 65 74 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 et-patt").
2710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2720: 20 20 22 25 22 29 29 0a 20 0a 20 20 20 20 20 20 "%")). .
2730: 20 20 20 20 20 28 72 75 6e 2d 74 69 6d 65 73 20 (run-times
2740: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 74 69 (rmt:get-run-ti
2750: 6d 65 73 20 20 72 75 6e 2d 70 61 74 74 20 74 61 mes run-patt ta
2760: 72 67 65 74 2d 70 61 74 74 20 29 29 29 0a 20 20 rget-patt ))).
2770: 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 (if (eq? (lengt
2780: 68 20 72 75 6e 2d 74 69 6d 65 73 29 20 30 29 0a h run-times) 0).
2790: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
27a0: 20 20 20 28 70 72 69 6e 74 20 22 44 61 74 61 20 (print "Data
27b0: 6e 6f 74 20 66 6f 75 6e 64 21 21 22 29 0a 20 20 not found!!").
27c0: 20 20 20 20 20 28 65 78 69 74 29 29 29 0a 20 20 (exit))).
27d0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 72 (if (equal? (ar
27e0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 75 6d gs:get-arg "-dum
27f0: 70 6d 6f 64 65 22 29 20 22 6a 73 6f 6e 22 29 0a pmode") "json").
2800: 20 20 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 (task:pri
2810: 6e 74 2d 72 75 6e 74 69 6d 65 2d 61 73 2d 6a 73 nt-runtime-as-js
2820: 6f 6e 20 72 75 6e 2d 74 69 6d 65 73 29 0a 20 20 on run-times).
2830: 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 (if (equa
2840: 6c 3f 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 l? (args:get-arg
2850: 20 22 2d 64 75 6d 70 6d 6f 64 65 22 29 20 22 63 "-dumpmode") "c
2860: 73 76 22 29 0a 09 20 20 20 20 20 28 74 61 73 6b sv").. (task
2870: 3a 70 72 69 6e 74 2d 72 75 6e 74 69 6d 65 20 72 :print-runtime r
2880: 75 6e 2d 74 69 6d 65 73 20 22 2c 22 29 0a 09 20 un-times ",")..
2890: 20 20 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 2d (task:print-
28a0: 72 75 6e 74 69 6d 65 20 72 75 6e 2d 74 69 6d 65 runtime run-time
28b0: 73 20 22 20 20 22 29 29 29 29 29 0a 0a 20 28 64 s " "))))).. (d
28c0: 65 66 69 6e 65 20 28 74 61 73 6b 3a 67 65 74 2d efine (task:get-
28d0: 74 65 73 74 2d 74 69 6d 65 73 29 0a 20 20 20 28 test-times). (
28e0: 6c 65 74 2a 20 28 28 72 75 6e 6e 61 6d 65 20 28 let* ((runname (
28f0: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
2900: 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 "-runname").
2910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2920: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
2930: 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 20 rg "-runname").
2940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2950: 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 #f)).
2960: 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 28 (target (
2970: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
2980: 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 "-target").
2990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29a0: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
29b0: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 20 g "-target").
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29d0: 20 20 20 20 20 23 66 29 29 0a 20 0a 20 20 20 20 #f)). .
29e0: 20 20 20 20 20 20 20 28 74 65 73 74 2d 74 69 6d (test-tim
29f0: 65 73 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 es (rmt:get-tes
2a00: 74 2d 74 69 6d 65 73 20 20 72 75 6e 6e 61 6d 65 t-times runname
2a10: 20 74 61 72 67 65 74 20 29 29 29 0a 20 20 20 28 target ))). (
2a20: 69 66 20 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 if (not runname)
2a30: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 . (begin.
2a40: 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f (print "Erro
2a50: 72 3a 20 4d 69 73 73 69 6e 67 20 61 72 67 75 6d r: Missing argum
2a60: 65 6e 74 20 2d 72 75 6e 6e 61 6d 65 22 29 0a 20 ent -runname").
2a70: 20 20 20 20 20 28 65 78 69 74 29 29 29 20 0a 20 (exit))) .
2a80: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 63 (if (string-c
2a90: 6f 6e 74 61 69 6e 73 20 72 75 6e 6e 61 6d 65 20 ontains runname
2aa0: 22 25 22 29 0a 20 20 20 20 20 20 28 62 65 67 69 "%"). (begi
2ab0: 6e 0a 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 n. (print "
2ac0: 45 72 72 6f 72 3a 20 49 6e 76 61 6c 69 64 20 72 Error: Invalid r
2ad0: 75 6e 6e 61 6d 65 2c 20 27 25 27 20 6e 6f 74 20 unname, '%' not
2ae0: 61 6c 6c 6f 77 65 64 20 20 28 22 20 72 75 6e 6e allowed (" runn
2af0: 61 6d 65 20 22 29 20 22 29 0a 20 20 20 20 20 20 ame ") ").
2b00: 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 69 66 (exit))). (if
2b10: 20 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 (not target).
2b20: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
2b30: 20 28 70 72 69 6e 74 20 22 45 72 72 6f 72 3a 20 (print "Error:
2b40: 4d 69 73 73 69 6e 67 20 61 72 67 75 6d 65 6e 74 Missing argument
2b50: 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 -target").
2b60: 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 20 28 (exit))). (
2b70: 69 66 20 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 if (string-cont
2b80: 61 69 6e 73 20 74 61 72 67 65 74 20 22 25 22 29 ains target "%")
2b90: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 . (begin.
2ba0: 20 20 20 20 28 70 72 69 6e 74 20 22 45 72 72 6f (print "Erro
2bb0: 72 3a 20 49 6e 76 61 6c 69 64 20 74 61 72 67 65 r: Invalid targe
2bc0: 74 2c 20 27 25 27 20 6e 6f 74 20 61 6c 6c 6f 77 t, '%' not allow
2bd0: 65 64 20 20 28 22 20 74 61 72 67 65 74 20 22 29 ed (" target ")
2be0: 20 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 29 "). (exit)
2bf0: 29 29 0a 20 0a 20 20 20 28 69 66 20 28 65 71 3f )). . (if (eq?
2c00: 20 28 6c 65 6e 67 74 68 20 74 65 73 74 2d 74 69 (length test-ti
2c10: 6d 65 73 29 20 30 29 0a 20 20 20 20 20 28 62 65 mes) 0). (be
2c20: 67 69 6e 0a 20 20 20 20 20 20 20 28 70 72 69 6e gin. (prin
2c30: 74 20 22 44 61 74 61 20 6e 6f 74 20 66 6f 75 6e t "Data not foun
2c40: 64 21 21 22 29 0a 20 20 20 20 20 20 20 28 65 78 d!!"). (ex
2c50: 69 74 29 29 29 0a 20 20 20 28 69 66 20 28 65 71 it))). (if (eq
2c60: 75 61 6c 3f 20 28 61 72 67 73 3a 67 65 74 2d 61 ual? (args:get-a
2c70: 72 67 20 22 2d 64 75 6d 70 6d 6f 64 65 22 29 20 rg "-dumpmode")
2c80: 22 6a 73 6f 6e 22 29 0a 20 20 20 20 20 20 20 28 "json"). (
2c90: 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 74 74 task:print-testt
2ca0: 69 6d 65 2d 61 73 2d 6a 73 6f 6e 20 74 65 73 74 ime-as-json test
2cb0: 2d 74 69 6d 65 73 29 0a 20 20 20 20 20 20 20 20 -times).
2cc0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 61 72 (if (equal? (ar
2cd0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 75 6d gs:get-arg "-dum
2ce0: 70 6d 6f 64 65 22 29 20 22 63 73 76 22 29 0a 09 pmode") "csv")..
2cf0: 20 20 20 20 20 28 74 61 73 6b 3a 70 72 69 6e 74 (task:print
2d00: 2d 74 65 73 74 74 69 6d 65 20 74 65 73 74 2d 74 -testtime test-t
2d10: 69 6d 65 73 20 22 2c 22 29 0a 09 20 20 20 20 20 imes ",")..
2d20: 28 74 61 73 6b 3a 70 72 69 6e 74 2d 74 65 73 74 (task:print-test
2d30: 74 69 6d 65 20 74 65 73 74 2d 74 69 6d 65 73 20 time test-times
2d40: 22 20 20 22 29 29 29 29 29 0a 0a 0a 0a 3b 3b 20 " ")))))....;;
2d50: 67 65 74 73 20 6d 74 70 67 2d 72 75 6e 2d 69 64 gets mtpg-run-id
2d60: 20 61 6e 64 20 73 79 6e 63 73 20 74 68 65 20 72 and syncs the r
2d70: 65 63 6f 72 64 20 69 66 20 64 69 66 66 65 72 65 ecord if differe
2d80: 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 nt.;;.(define (t
2d90: 61 73 6b 73 3a 72 75 6e 2d 69 64 2d 3e 6d 74 70 asks:run-id->mtp
2da0: 67 2d 72 75 6e 2d 69 64 20 64 62 68 20 63 61 63 g-run-id dbh cac
2db0: 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 hed-info run-id
2dc0: 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 area-info smalle
2dd0: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
2de0: 69 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 ime). (let* ((r
2df0: 75 6e 73 2d 68 74 20 28 68 61 73 68 2d 74 61 62 uns-ht (hash-tab
2e00: 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 6e le-ref cached-in
2e10: 66 6f 20 27 72 75 6e 73 29 29 0a 09 20 28 72 75 fo 'runs)).. (ru
2e20: 6e 69 6e 66 20 20 28 68 61 73 68 2d 74 61 62 6c ninf (hash-tabl
2e30: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 75 e-ref/default ru
2e40: 6e 73 2d 68 74 20 72 75 6e 2d 69 64 20 23 66 29 ns-ht run-id #f)
2e50: 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 61 ). (area
2e60: 2d 69 64 20 28 76 65 63 74 6f 72 2d 72 65 66 20 -id (vector-ref
2e70: 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 29 0a 20 area-info 0))).
2e80: 20 20 20 20 20 20 28 69 66 20 72 75 6e 69 6e 66 (if runinf
2e90: 0a 09 72 75 6e 69 6e 66 20 3b 3b 20 61 6c 72 65 ..runinf ;; alre
2ea0: 61 64 79 20 63 61 63 68 65 64 0a 09 28 6c 65 74 ady cached..(let
2eb0: 2a 20 28 28 72 75 6e 2d 64 61 74 20 20 20 20 28 * ((run-dat (
2ec0: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f rmt:get-run-info
2ed0: 20 72 75 6e 2d 69 64 29 29 20 20 20 20 20 20 20 run-id))
2ee0: 20 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a ;; NOTE:
2ef0: 20 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 65 get-run-info re
2f00: 74 75 72 6e 73 20 61 20 76 65 63 74 6f 72 20 3c turns a vector <
2f10: 20 72 6f 77 20 68 65 61 64 65 72 20 3e 0a 09 20 row header >..
2f20: 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 (run-name
2f30: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e (rmt:get-run-n
2f40: 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d ame-from-id run-
2f50: 69 64 29 29 0a 09 20 20 20 20 20 20 20 28 72 6f id)).. (ro
2f60: 77 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 w (db:get
2f70: 2d 72 6f 77 73 20 72 75 6e 2d 64 61 74 29 29 20 -rows run-dat))
2f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f90: 20 20 3b 3b 20 79 65 73 2c 20 74 68 69 73 20 72 ;; yes, this r
2fa0: 65 74 75 72 6e 73 20 61 20 73 69 6e 67 6c 65 20 eturns a single
2fb0: 72 6f 77 0a 09 20 20 20 20 20 20 20 28 68 65 61 row.. (hea
2fc0: 64 65 72 20 20 20 20 20 28 64 62 3a 67 65 74 2d der (db:get-
2fd0: 68 65 61 64 65 72 20 72 75 6e 2d 64 61 74 29 29 header run-dat))
2fe0: 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 65 20 .. (state
2ff0: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c (db:get-val
3000: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f 77 ue-by-header row
3010: 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 29 header "state")
3020: 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 75 ).. (statu
3030: 73 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 s (db:get-va
3040: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f lue-by-header ro
3050: 77 20 68 65 61 64 65 72 20 22 73 74 61 74 75 73 w header "status
3060: 22 29 29 0a 09 20 20 20 20 20 20 20 28 6f 77 6e ")).. (own
3070: 65 72 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d er (db:get-
3080: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
3090: 72 6f 77 20 68 65 61 64 65 72 20 22 6f 77 6e 65 row header "owne
30a0: 72 22 29 29 0a 09 20 20 20 20 20 20 20 28 65 76 r")).. (ev
30b0: 65 6e 74 2d 74 69 6d 65 20 28 64 62 3a 67 65 74 ent-time (db:get
30c0: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
30d0: 20 72 6f 77 20 68 65 61 64 65 72 20 22 65 76 65 row header "eve
30e0: 6e 74 5f 74 69 6d 65 22 29 29 0a 09 20 20 20 20 nt_time"))..
30f0: 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 28 (comment (
3100: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
3110: 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 65 header row heade
3120: 72 20 22 63 6f 6d 6d 65 6e 74 22 29 29 0a 09 20 r "comment"))..
3130: 20 20 20 20 20 20 28 66 61 69 6c 2d 63 6f 75 6e (fail-coun
3140: 74 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d t (db:get-value-
3150: 62 79 2d 68 65 61 64 65 72 20 72 6f 77 20 68 65 by-header row he
3160: 61 64 65 72 20 22 66 61 69 6c 5f 63 6f 75 6e 74 ader "fail_count
3170: 22 29 29 0a 09 20 20 20 20 20 20 20 28 70 61 73 ")).. (pas
3180: 73 2d 63 6f 75 6e 74 20 28 64 62 3a 67 65 74 2d s-count (db:get-
3190: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
31a0: 72 6f 77 20 68 65 61 64 65 72 20 22 70 61 73 73 row header "pass
31b0: 5f 63 6f 75 6e 74 22 29 29 0a 20 20 20 20 20 20 _count")).
31c0: 20 20 20 28 64 62 2d 63 6f 6e 74 6f 75 72 20 28 (db-contour (
31d0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
31e0: 68 65 61 64 65 72 20 72 6f 77 20 68 65 61 64 65 header row heade
31f0: 72 20 22 63 6f 6e 74 6f 75 72 22 29 29 0a 09 20 r "contour"))..
3200: 20 20 20 20 20 20 28 63 6f 6e 74 6f 75 72 20 20 (contour
3210: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
3220: 61 72 67 20 22 2d 70 72 65 70 65 6e 64 2d 63 6f arg "-prepend-co
3230: 6e 74 6f 75 72 22 29 20 0a 20 20 20 20 20 20 20 ntour") .
3240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3250: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
3260: 6e 64 20 64 62 2d 63 6f 6e 74 6f 75 72 20 28 6e nd db-contour (n
3270: 6f 74 20 28 65 71 75 61 6c 3f 20 64 62 2d 63 6f ot (equal? db-co
3280: 6e 74 6f 75 72 20 22 22 29 29 20 20 28 73 74 72 ntour "")) (str
3290: 69 6e 67 3f 20 64 62 2d 63 6f 6e 74 6f 75 72 20 ing? db-contour
32a0: 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 )) .
32b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
32d0: 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 20 begin .
32e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3300: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3310: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
3320: 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 64 62 2d 63 log-port* "db-c
3330: 6f 6e 74 6f 75 72 22 29 20 0a 20 09 09 09 09 09 ontour") . .....
3340: 09 64 62 2d 63 6f 6e 74 6f 75 72 29 0a 09 09 09 .db-contour)....
3350: 09 09 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d .. (args:get-
3360: 61 72 67 20 22 2d 63 6f 6e 74 6f 75 72 22 29 29 arg "-contour"))
3370: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 6e )). (run
3380: 2d 74 61 67 20 28 69 66 20 28 61 72 67 73 3a 67 -tag (if (args:g
3390: 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 74 61 67 et-arg "-run-tag
33a0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
33b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
33c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
33d0: 75 6e 2d 74 61 67 22 29 0a 09 09 09 09 09 09 09 un-tag")........
33e0: 09 09 22 22 29 29 0a 20 20 20 20 20 20 20 20 20 .."")).
33f0: 28 6c 61 73 74 2d 75 70 64 61 74 65 20 28 64 62 (last-update (db
3400: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
3410: 61 64 65 72 20 72 6f 77 20 68 65 61 64 65 72 20 ader row header
3420: 22 6c 61 73 74 5f 75 70 64 61 74 65 22 29 29 0a "last_update")).
3430: 09 20 20 20 20 20 20 20 28 6b 65 79 74 61 72 67 . (keytarg
3440: 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 67 (if (or (arg
3450: 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 70 s:get-arg "-prep
3460: 65 6e 64 2d 63 6f 6e 74 6f 75 72 22 29 20 28 61 end-contour") (a
3470: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 rgs:get-arg "-pr
3480: 65 66 69 78 2d 74 61 72 67 65 74 22 29 29 0a 09 efix-target"))..
3490: 20 20 20 20 20 20 20 09 09 09 28 63 6f 6e 63 20 ...(conc
34a0: 22 4d 54 5f 43 4f 4e 54 4f 55 52 2f 4d 54 5f 41 "MT_CONTOUR/MT_A
34b0: 52 45 41 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e REA/" (string-in
34c0: 74 65 72 73 70 65 72 73 65 20 28 72 6d 74 3a 67 tersperse (rmt:g
34d0: 65 74 2d 6b 65 79 73 29 20 22 2f 22 29 29 20 28 et-keys) "/")) (
34e0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
34f0: 73 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 se (rmt:get-keys
3500: 29 20 22 2f 22 29 29 29 20 3b 3b 20 65 2e 67 2e ) "/"))) ;; e.g.
3510: 20 76 65 72 73 69 6f 6e 2f 69 74 65 72 61 74 69 version/iterati
3520: 6f 6e 2f 70 6c 61 74 66 6f 72 6d 0a 09 20 20 20 on/platform..
3530: 20 20 20 20 28 74 61 72 67 65 74 20 20 20 20 20 (target
3540: 28 69 66 20 28 6f 72 20 28 61 72 67 73 3a 67 65 (if (or (args:ge
3550: 74 2d 61 72 67 20 22 2d 70 72 65 70 65 6e 64 2d t-arg "-prepend-
3560: 63 6f 6e 74 6f 75 72 22 29 20 28 61 72 67 73 3a contour") (args:
3570: 67 65 74 2d 61 72 67 20 22 2d 70 72 65 66 69 78 get-arg "-prefix
3580: 2d 74 61 72 67 65 74 22 29 29 20 0a 09 20 20 20 -target")) ..
3590: 20 20 20 20 09 09 09 28 63 6f 6e 63 20 28 6f 72 ...(conc (or
35a0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
35b0: 2d 70 72 65 66 69 78 2d 74 61 72 67 65 74 22 29 -prefix-target")
35c0: 20 28 63 6f 6e 63 20 63 6f 6e 74 6f 75 72 20 22 (conc contour "
35d0: 2f 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 /" (common:get-a
35e0: 72 65 61 2d 6e 61 6d 65 29 20 22 2f 22 29 29 20 rea-name) "/"))
35f0: 28 72 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 20 (rmt:get-target
3600: 72 75 6e 2d 69 64 29 29 20 28 72 6d 74 3a 67 65 run-id)) (rmt:ge
3610: 74 2d 74 61 72 67 65 74 20 72 75 6e 2d 69 64 29 t-target run-id)
3620: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
3630: 20 20 20 3b 3b 20 65 2e 67 2e 20 76 31 2e 36 33 ;; e.g. v1.63
3640: 2f 61 33 65 31 2f 75 62 75 6e 74 75 0a 09 20 20 /a3e1/ubuntu..
3650: 20 20 20 20 20 28 73 70 65 63 2d 69 64 20 20 20 (spec-id
3660: 20 28 70 67 64 62 3a 67 65 74 2d 74 74 79 70 65 (pgdb:get-ttype
3670: 20 64 62 68 20 6b 65 79 74 61 72 67 29 29 0a 09 dbh keytarg))..
3680: 20 20 20 20 20 20 20 28 70 75 62 6c 69 73 68 2d (publish-
3690: 74 69 6d 65 20 28 69 66 20 28 61 72 67 73 3a 67 time (if (args:g
36a0: 65 74 2d 61 72 67 20 22 2d 63 70 2d 65 76 65 6e et-arg "-cp-even
36b0: 74 74 69 6d 65 2d 74 6f 2d 70 75 62 6c 69 73 68 ttime-to-publish
36c0: 74 69 6d 65 22 29 0a 20 20 20 20 20 20 20 20 20 time").
36d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36e0: 20 20 20 65 76 65 6e 74 2d 74 69 6d 65 0a 20 20 event-time.
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3700: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 6e (curren
3710: 74 2d 73 65 63 6f 6e 64 73 29 29 29 20 0a 09 20 t-seconds))) ..
3720: 20 20 20 20 20 20 28 6e 65 77 2d 72 75 6e 2d 69 (new-run-i
3730: 64 20 28 70 67 64 62 3a 67 65 74 2d 72 75 6e 2d d (pgdb:get-run-
3740: 69 64 20 64 62 68 20 73 70 65 63 2d 69 64 20 74 id dbh spec-id t
3750: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 61 arget run-name a
3760: 72 65 61 2d 69 64 29 29 29 0a 20 20 20 20 20 20 rea-id))).
3770: 20 20 20 28 69 66 20 6e 65 77 2d 72 75 6e 2d 69 (if new-run-i
3780: 64 0a 09 20 20 20 20 20 20 20 20 20 28 62 65 67 d.. (beg
3790: 69 6e 20 3b 3b 20 6c 65 74 20 28 28 72 75 6e 2d in ;; let ((run-
37a0: 72 65 63 6f 72 64 20 28 70 67 64 62 3a 67 65 74 record (pgdb:get
37b0: 2d 72 75 6e 2d 69 6e 66 6f 20 64 62 68 20 6e 65 -run-info dbh ne
37c0: 77 2d 72 75 6e 2d 69 64 29 29 0a 09 09 20 20 20 w-run-id))...
37d0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
37e0: 2d 73 65 74 21 20 72 75 6e 73 2d 68 74 20 72 75 -set! runs-ht ru
37f0: 6e 2d 69 64 20 6e 65 77 2d 72 75 6e 2d 69 64 29 n-id new-run-id)
3800: 0a 09 09 3b 3b 20 65 6e 73 75 72 65 20 6b 65 79 ...;; ensure key
3810: 20 66 69 65 6c 64 73 20 61 72 65 20 75 70 20 74 fields are up t
3820: 6f 20 64 61 74 65 0a 20 20 20 20 20 3b 3b 20 69 o date. ;; i
3830: 66 20 6c 61 73 74 5f 75 70 64 61 74 65 20 3d 3d f last_update ==
3840: 20 70 67 64 62 5f 6c 61 73 74 5f 75 70 64 61 74 pgdb_last_updat
3850: 65 20 64 6f 20 6e 6f 74 20 75 70 64 61 74 65 20 e do not update
3860: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
3870: 64 61 74 65 2d 74 69 6d 65 20 20 0a 20 20 20 20 date-time .
3880: 28 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 (let* ((pgdb-las
3890: 74 2d 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 t-update (pgdb:g
38a0: 65 74 2d 72 75 6e 2d 6c 61 73 74 2d 75 70 64 61 et-run-last-upda
38b0: 74 65 20 64 62 68 20 6e 65 77 2d 72 75 6e 2d 69 te dbh new-run-i
38c0: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 d)). (
38d0: 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 smallest-time (h
38e0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
38f0: 66 61 75 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c fault smallest-l
3900: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
3910: 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 "smallest-time"
3920: 23 66 29 29 29 0a 20 20 20 20 20 28 69 66 20 28 #f))). (if (
3930: 61 6e 64 20 20 28 3e 20 6c 61 73 74 2d 75 70 64 and (> last-upd
3940: 61 74 65 20 70 67 64 62 2d 6c 61 73 74 2d 75 70 ate pgdb-last-up
3950: 64 61 74 65 29 20 28 6f 72 20 28 6e 6f 74 20 73 date) (or (not s
3960: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 28 3c mallest-time) (<
3970: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 73 6d 61 last-update sma
3980: 6c 6c 65 73 74 2d 74 69 6d 65 29 29 29 0a 20 20 llest-time))).
3990: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
39a0: 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d e-set! smallest-
39b0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
39c0: 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 "smallest-time"
39d0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a last-update))).
39e0: 09 09 28 70 67 64 62 3a 72 65 66 72 65 73 68 2d ..(pgdb:refresh-
39f0: 72 75 6e 2d 69 6e 66 6f 0a 09 09 20 64 62 68 0a run-info... dbh.
3a00: 09 09 20 6e 65 77 2d 72 75 6e 2d 69 64 0a 09 09 .. new-run-id...
3a10: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 6f 77 state status ow
3a20: 6e 65 72 20 65 76 65 6e 74 2d 74 69 6d 65 20 63 ner event-time c
3a30: 6f 6d 6d 65 6e 74 20 66 61 69 6c 2d 63 6f 75 6e omment fail-coun
3a40: 74 20 70 61 73 73 2d 63 6f 75 6e 74 20 61 72 65 t pass-count are
3a50: 61 2d 69 64 20 6c 61 73 74 2d 75 70 64 61 74 65 a-id last-update
3a60: 20 70 75 62 6c 69 73 68 2d 74 69 6d 65 29 0a 20 publish-time).
3a70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3a80: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
3a90: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 6f 72 6b -log-port* "Work
3aa0: 69 6e 67 20 6f 6e 20 72 75 6e 2d 69 64 20 22 20 ing on run-id "
3ab0: 72 75 6e 2d 69 64 20 22 20 70 67 64 62 2d 69 64 run-id " pgdb-id
3ac0: 20 22 20 20 6e 65 77 2d 72 75 6e 2d 69 64 20 29 " new-run-id )
3ad0: 0a 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 . (if (not (
3ae0: 65 71 75 61 6c 3f 20 72 75 6e 2d 74 61 67 20 22 equal? run-tag "
3af0: 22 29 29 0a 20 20 20 20 20 20 28 74 61 73 6b 3a ")). (task:
3b00: 61 64 64 2d 72 75 6e 2d 74 61 67 20 64 62 68 20 add-run-tag dbh
3b10: 6e 65 77 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 74 new-run-id run-t
3b20: 61 67 29 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 ag))...new-run-i
3b30: 64 29 20 0a 20 20 20 20 20 20 0a 09 20 20 20 20 d) . ..
3b40: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 74 (if (equal? st
3b50: 61 74 65 20 22 64 65 6c 65 74 65 64 22 29 0a 20 ate "deleted").
3b60: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
3b70: 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 . (debu
3b80: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
3b90: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3ba0: 2a 20 20 22 57 61 72 6e 69 6e 67 3a 20 52 75 6e * "Warning: Run
3bb0: 20 77 69 74 68 20 69 64 20 22 20 72 75 6e 2d 69 with id " run-i
3bc0: 64 20 22 20 77 61 73 20 63 72 65 61 74 65 64 20 d " was created
3bd0: 61 66 74 65 72 20 70 72 65 76 69 6f 75 73 20 73 after previous s
3be0: 79 6e 63 20 61 6e 64 20 64 65 6c 65 74 65 64 20 ync and deleted
3bf0: 62 65 66 6f 72 65 20 74 68 65 20 73 79 6e 63 22 before the sync"
3c00: 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 ) #f).
3c10: 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (if (handle-exce
3c20: 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 20 20 20 ptions...
3c30: 20 65 78 6e 0a 09 09 20 20 20 20 20 20 20 20 28 exn... (
3c40: 62 65 67 69 6e 20 28 70 72 69 6e 74 2d 63 61 6c begin (print-cal
3c50: 6c 2d 63 68 61 69 6e 29 0a 20 20 20 20 20 20 20 l-chain).
3c60: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 28 28 (print ((
3c70: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
3c80: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
3c90: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
3ca0: 20 20 20 20 20 0a 09 09 09 20 20 20 20 20 20 23 .... #
3cb0: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0a f). .
3cc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
3cd0: 62 3a 69 6e 73 65 72 74 2d 72 75 6e 0a 09 09 20 b:insert-run...
3ce0: 20 20 20 20 64 62 68 0a 09 09 20 20 20 20 20 73 dbh... s
3cf0: 70 65 63 2d 69 64 20 74 61 72 67 65 74 20 72 75 pec-id target ru
3d00: 6e 2d 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 n-name state sta
3d10: 74 75 73 20 6f 77 6e 65 72 20 65 76 65 6e 74 2d tus owner event-
3d20: 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 66 61 69 time comment fai
3d30: 6c 2d 63 6f 75 6e 74 20 70 61 73 73 2d 63 6f 75 l-count pass-cou
3d40: 6e 74 20 20 61 72 65 61 2d 69 64 20 6c 61 73 74 nt area-id last
3d50: 2d 75 70 64 61 74 65 20 70 75 62 6c 69 73 68 2d -update publish-
3d60: 74 69 6d 65 29 29 0a 09 09 20 20 20 20 20 20 20 time))...
3d70: 28 6c 65 74 2a 20 28 28 73 6d 61 6c 6c 65 73 74 (let* ((smallest
3d80: 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c -time (hash-tabl
3d90: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6d e-ref/default sm
3da0: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
3db0: 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 te-time "smalles
3dc0: 74 2d 74 69 6d 65 22 20 23 66 29 29 29 0a 20 20 t-time" #f))).
3dd0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
3de0: 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 or (not smallest
3df0: 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 -time) (< last-u
3e00: 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 pdate smallest-t
3e10: 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 09 09 ime)). ..
3e20: 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 ..(hash-table-se
3e30: 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 t! smallest-last
3e40: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d -update-time "sm
3e50: 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 allest-time" las
3e60: 74 2d 75 70 64 61 74 65 29 29 0a 20 20 20 20 20 t-update)).
3e70: 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a 72 (tasks:r
3e80: 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d un-id->mtpg-run-
3e90: 69 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e id dbh cached-in
3ea0: 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 69 fo run-id area-i
3eb0: 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 nfo smallest-las
3ec0: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 29 0a t-update-time)).
3ed0: 09 09 20 20 23 66 29 29 29 29 29 29 29 0a 0a 28 .. #f)))))))..(
3ee0: 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 61 64 64 define (task:add
3ef0: 2d 72 75 6e 2d 74 61 67 20 64 62 68 20 72 75 6e -run-tag dbh run
3f00: 2d 69 64 20 74 61 67 29 20 0a 20 20 28 6c 65 74 -id tag) . (let
3f10: 2a 20 28 28 74 61 67 2d 69 6e 66 6f 20 28 70 67 * ((tag-info (pg
3f20: 64 62 3a 67 65 74 2d 74 61 67 2d 69 6e 66 6f 2d db:get-tag-info-
3f30: 62 79 2d 6e 61 6d 65 20 64 62 68 20 74 61 67 29 by-name dbh tag)
3f40: 29 29 0a 20 20 20 28 69 66 20 28 6e 6f 74 20 74 )). (if (not t
3f50: 61 67 2d 69 6e 66 6f 29 0a 20 20 20 20 20 28 62 ag-info). (b
3f60: 65 67 69 6e 20 20 20 0a 20 20 20 20 20 28 69 66 egin . (if
3f70: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
3f80: 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 20 ons.. exn..
3f90: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
3fa0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
3fb0: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
3fc0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 ult-log-port* (
3fd0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
3fe0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
3ff0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
4000: 29 20 20 20 20 20 0a 09 20 20 20 23 66 29 0a 09 ) .. #f)..
4010: 20 20 20 28 70 67 64 62 3a 69 6e 73 65 72 74 2d (pgdb:insert-
4020: 74 61 67 20 20 64 62 68 20 20 20 74 61 67 29 29 tag dbh tag))
4030: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4040: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 74 61 (set! ta
4050: 67 2d 69 6e 66 6f 20 28 70 67 64 62 3a 67 65 74 g-info (pgdb:get
4060: 2d 74 61 67 2d 69 6e 66 6f 2d 62 79 2d 6e 61 6d -tag-info-by-nam
4070: 65 20 64 62 68 20 74 61 67 29 29 0a 09 09 20 20 e dbh tag))...
4080: 23 66 29 29 29 0a 20 20 20 20 20 3b 3b 61 64 64 #f))). ;;add
4090: 20 74 6f 20 61 72 65 61 5f 74 61 67 73 0a 20 20 to area_tags.
40a0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
40b0: 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 tions.. exn..
40c0: 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 (begin .
40d0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
40e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 print-info 1 *de
40f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4100: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
4110: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
4120: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
4130: 6e 29 29 20 20 20 20 20 0a 09 20 20 20 23 66 29 n)) .. #f)
4140: 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 . (if
4150: 28 6e 6f 74 20 28 70 67 64 62 3a 69 73 2d 72 75 (not (pgdb:is-ru
4160: 6e 2d 74 61 67 65 64 2d 77 69 74 68 2d 61 2d 74 n-taged-with-a-t
4170: 61 67 20 64 62 68 20 28 76 65 63 74 6f 72 2d 72 ag dbh (vector-r
4180: 65 66 20 74 61 67 2d 69 6e 66 6f 20 30 29 20 20 ef tag-info 0)
4190: 72 75 6e 2d 69 64 29 29 20 20 0a 09 20 20 20 28 run-id)) .. (
41a0: 70 67 64 62 3a 69 6e 73 65 72 74 2d 72 75 6e 2d pgdb:insert-run-
41b0: 74 61 67 20 20 64 62 68 20 20 20 28 76 65 63 74 tag dbh (vect
41c0: 6f 72 2d 72 65 66 20 74 61 67 2d 69 6e 66 6f 20 or-ref tag-info
41d0: 30 29 20 20 72 75 6e 2d 69 64 29 29 29 29 29 0a 0) run-id))))).
41e0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 73 ..(define (tasks
41f0: 3a 73 79 6e 63 2d 74 65 73 74 2d 73 74 65 70 73 :sync-test-steps
4200: 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f dbh cached-info
4210: 20 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 73 test-step-ids s
4220: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
4230: 61 74 65 2d 74 69 6d 65 29 0a 20 3b 20 28 70 72 ate-time). ; (pr
4240: 69 6e 74 20 22 53 79 6e 63 20 53 74 65 70 73 20 int "Sync Steps
4250: 22 20 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 " test-step-ids
4260: 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d ). (let ((test-
4270: 68 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ht (hash-table-r
4280: 65 66 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 27 ef cached-info '
4290: 74 65 73 74 73 29 29 0a 20 20 20 20 20 20 20 20 tests)).
42a0: 28 73 74 65 70 2d 68 74 20 28 68 61 73 68 2d 74 (step-ht (hash-t
42b0: 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 2d able-ref cached-
42c0: 69 6e 66 6f 20 27 73 74 65 70 73 29 29 29 0a 20 info 'steps))).
42d0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
42e0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
42f0: 73 74 65 70 2d 69 64 29 0a 20 20 20 20 20 20 20 step-id).
4300: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 74 (let* ((test-st
4310: 65 70 2d 69 6e 66 6f 20 20 28 72 6d 74 3a 67 65 ep-info (rmt:ge
4320: 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d t-steps-info-by-
4330: 69 64 20 74 65 73 74 2d 73 74 65 70 2d 69 64 29 id test-step-id)
4340: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4350: 20 28 73 74 65 70 2d 69 64 20 28 74 64 62 3a 73 (step-id (tdb:s
4360: 74 65 70 2d 67 65 74 2d 69 64 20 74 65 73 74 2d tep-get-id test-
4370: 73 74 65 70 2d 69 6e 66 6f 29 29 0a 20 20 20 20 step-info)).
4380: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
4390: 2d 69 64 20 20 28 74 64 62 3a 73 74 65 70 2d 67 -id (tdb:step-g
43a0: 65 74 2d 74 65 73 74 5f 69 64 20 20 20 20 74 65 et-test_id te
43b0: 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 20 20 st-step-info))
43c0: 20 0a 09 20 20 20 20 20 20 20 28 73 74 65 70 6e .. (stepn
43d0: 61 6d 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 ame (tdb:step-ge
43e0: 74 2d 73 74 65 70 6e 61 6d 65 20 20 74 65 73 74 t-stepname test
43f0: 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 -step-info))..
4400: 20 20 20 20 20 28 73 74 61 74 65 20 28 74 64 62 (state (tdb
4410: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 :step-get-state
4420: 74 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 29 test-step-info))
4430: 09 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 75 ... (statu
4440: 73 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d s (tdb:step-get-
4450: 73 74 61 74 75 73 20 74 65 73 74 2d 73 74 65 70 status test-step
4460: 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 20 20 20 -info))...
4470: 20 28 65 76 65 6e 74 5f 74 69 6d 65 20 28 74 64 (event_time (td
4480: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
4490: 5f 74 69 6d 65 20 20 74 65 73 74 2d 73 74 65 70 _time test-step
44a0: 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 20 20 20 -info))...
44b0: 20 28 63 6f 6d 6d 65 6e 74 20 20 28 74 64 62 3a (comment (tdb:
44c0: 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 step-get-comment
44d0: 20 74 65 73 74 2d 73 74 65 70 2d 69 6e 66 6f 29 test-step-info)
44e0: 29 09 0a 09 20 20 20 20 20 20 20 28 6c 6f 67 66 )... (logf
44f0: 69 6c 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 ile (tdb:step-ge
4500: 74 2d 6c 6f 67 66 69 6c 65 20 74 65 73 74 2d 73 t-logfile test-s
4510: 74 65 70 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 tep-info))..
4520: 20 20 20 20 20 28 6c 61 73 74 2d 75 70 64 61 74 (last-updat
4530: 65 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d e (tdb:step-get-
4540: 6c 61 73 74 5f 75 70 64 61 74 65 20 74 65 73 74 last_update test
4550: 2d 73 74 65 70 2d 69 6e 66 6f 29 29 0a 09 20 20 -step-info))..
4560: 20 20 20 20 20 28 70 67 64 62 2d 74 65 73 74 2d (pgdb-test-
4570: 69 64 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d id (hash-table-
4580: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
4590: 2d 68 74 20 74 65 73 74 2d 69 64 20 23 66 29 29 -ht test-id #f))
45a0: 0a 09 09 09 09 20 28 73 6d 61 6c 6c 65 73 74 2d ..... (smallest-
45b0: 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 time (hash-table
45c0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 -ref/default sma
45d0: 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 llest-last-updat
45e0: 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 e-time "smallest
45f0: 2d 74 69 6d 65 22 20 23 66 29 29 0a 20 20 20 20 -time" #f)).
4600: 20 20 20 20 20 28 70 67 64 62 2d 73 74 65 70 2d (pgdb-step-
4610: 69 64 20 28 69 66 20 70 67 64 62 2d 74 65 73 74 id (if pgdb-test
4620: 2d 69 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 -id .
4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
4640: 67 64 62 3a 67 65 74 2d 74 65 73 74 2d 73 74 65 gdb:get-test-ste
4650: 70 2d 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 p-id dbh pgdb-te
4660: 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 73 st-id stepname s
4670: 74 61 74 65 29 0a 20 20 20 20 20 20 20 20 20 20 tate).
4680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4690: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 73 74 #f))). (if st
46a0: 65 70 2d 69 64 0a 20 20 20 20 20 20 28 62 65 67 ep-id. (beg
46b0: 69 6e 20 20 0a 20 20 20 20 20 20 20 20 28 69 66 in . (if
46c0: 20 70 67 64 62 2d 74 65 73 74 2d 69 64 0a 20 20 pgdb-test-id.
46d0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
46e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
46f0: 20 28 69 66 20 20 70 67 64 62 2d 73 74 65 70 2d (if pgdb-step-
4700: 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 id.
4710: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
4720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4730: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4740: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
4750: 67 2d 70 6f 72 74 2a 20 20 22 55 70 64 61 74 69 g-port* "Updati
4760: 6e 67 20 65 78 69 73 74 69 6e 67 20 74 65 73 74 ng existing test
4770: 2d 73 74 65 70 20 77 69 74 68 20 74 65 73 74 2d -step with test-
4780: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 id: " test-id "
4790: 61 6e 64 20 73 74 65 70 2d 69 64 20 22 20 73 74 and step-id " st
47a0: 65 70 2d 69 64 20 22 20 70 67 64 62 20 74 65 73 ep-id " pgdb tes
47b0: 74 20 69 64 3a 20 22 20 70 67 64 62 2d 74 65 73 t id: " pgdb-tes
47c0: 74 2d 69 64 20 22 20 70 67 64 62 20 73 74 65 70 t-id " pgdb step
47d0: 20 69 64 20 22 20 70 67 64 62 2d 73 74 65 70 2d id " pgdb-step-
47e0: 69 64 20 29 0a 09 09 09 09 09 09 09 09 09 09 28 id )...........(
47f0: 6c 65 74 2a 20 28 28 70 67 64 62 2d 6c 61 73 74 let* ((pgdb-last
4800: 2d 75 70 64 61 74 65 20 28 70 67 64 62 3a 67 65 -update (pgdb:ge
4810: 74 2d 74 65 73 74 2d 73 74 65 70 2d 6c 61 73 74 t-test-step-last
4820: 2d 75 70 64 61 74 65 20 64 62 68 20 70 67 64 62 -update dbh pgdb
4830: 2d 73 74 65 70 2d 69 64 29 29 29 0a 20 20 20 20 -step-id))).
4840: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 20 28 (if (and (
4850: 3e 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 67 > last-update pg
4860: 64 62 2d 6c 61 73 74 2d 75 70 64 61 74 65 29 20 db-last-update)
4870: 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 (or (not smalles
4880: 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d t-time) (< last-
4890: 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d update smallest-
48a0: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 time))).
48b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
48c0: 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 smallest-last-u
48d0: 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c pdate-time "smal
48e0: 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d lest-time" last-
48f0: 75 70 64 61 74 65 29 29 29 20 0a 20 20 20 20 20 update))) .
4900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4910: 70 67 64 62 3a 75 70 64 61 74 65 2d 74 65 73 74 pgdb:update-test
4920: 2d 73 74 65 70 20 64 62 68 20 70 67 64 62 2d 73 -step dbh pgdb-s
4930: 74 65 70 2d 69 64 20 70 67 64 62 2d 74 65 73 74 tep-id pgdb-test
4940: 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 73 74 61 -id stepname sta
4950: 74 65 20 73 74 61 74 75 73 20 65 76 65 6e 74 5f te status event_
4960: 74 69 6d 65 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 time comment log
4970: 66 69 6c 65 20 6c 61 73 74 2d 75 70 64 61 74 65 file last-update
4980: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
4990: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 09 (begin. .
49a0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
49b0: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
49c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
49d0: 49 6e 73 65 72 74 69 6e 67 20 74 65 73 74 2d 73 Inserting test-s
49e0: 74 65 70 20 77 69 74 68 20 74 65 73 74 2d 69 64 tep with test-id
49f0: 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 61 6e : " test-id " an
4a00: 64 20 73 74 65 70 2d 69 64 20 22 20 73 74 65 70 d step-id " step
4a10: 2d 69 64 20 20 22 20 70 67 64 62 20 74 65 73 74 -id " pgdb test
4a20: 20 69 64 3a 20 22 20 70 67 64 62 2d 74 65 73 74 id: " pgdb-test
4a30: 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 -id).
4a40: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6f (if (o
4a50: 72 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d r (not smallest-
4a60: 74 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 time) (< last-up
4a70: 64 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 date smallest-ti
4a80: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 09 09 09 me)). ...
4a90: 09 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
4aa0: 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 le-set! smallest
4ab0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d -last-update-tim
4ac0: 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 e "smallest-time
4ad0: 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a " last-update)).
4ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4af0: 20 20 20 20 20 20 28 70 67 64 62 3a 69 6e 73 65 (pgdb:inse
4b00: 72 74 2d 74 65 73 74 2d 73 74 65 70 20 64 62 68 rt-test-step dbh
4b10: 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 73 74 pgdb-test-id st
4b20: 65 70 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 epname state sta
4b30: 74 75 73 20 65 76 65 6e 74 5f 74 69 6d 65 20 63 tus event_time c
4b40: 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 20 6c omment logfile l
4b50: 61 73 74 2d 75 70 64 61 74 65 20 29 0a 20 20 20 ast-update ).
4b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b70: 20 20 20 28 73 65 74 21 20 70 67 64 62 2d 73 74 (set! pgdb-st
4b80: 65 70 2d 69 64 20 20 28 70 67 64 62 3a 67 65 74 ep-id (pgdb:get
4b90: 2d 74 65 73 74 2d 73 74 65 70 2d 69 64 20 64 62 -test-step-id db
4ba0: 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 73 h pgdb-test-id s
4bb0: 74 65 70 6e 61 6d 65 20 73 74 61 74 65 29 29 29 tepname state)))
4bc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4bd0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
4be0: 74 21 20 73 74 65 70 2d 68 74 20 73 74 65 70 2d t! step-ht step-
4bf0: 69 64 20 70 67 64 62 2d 73 74 65 70 2d 69 64 20 id pgdb-step-id
4c00: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 )). (d
4c10: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4c20: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
4c30: 6f 72 74 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 ort* "Error: Te
4c40: 73 74 20 6e 6f 74 20 63 61 73 68 65 64 22 29 29 st not cashed"))
4c50: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
4c60: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 rint-info 1 *def
4c70: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
4c80: 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 20 6e 6f "Error: Could no
4c90: 74 20 67 65 74 20 74 65 73 74 20 73 74 65 70 20 t get test step
4ca0: 69 6e 66 6f 20 66 6f 72 20 73 74 65 70 20 69 64 info for step id
4cb0: 20 22 20 74 65 73 74 2d 73 74 65 70 2d 69 64 20 " test-step-id
4cc0: 29 29 29 29 09 3b 3b 20 74 68 69 73 20 69 73 20 )))).;; this is
4cd0: 61 20 77 69 65 72 64 20 73 65 6e 61 72 69 6f 20 a wierd senario
4ce0: 6e 65 65 64 20 74 6f 20 64 65 62 75 67 20 20 20 need to debug
4cf0: 20 20 20 09 0a 20 20 20 74 65 73 74 2d 73 74 65 .. test-ste
4d00: 70 2d 69 64 73 29 29 29 0a 0a 28 64 65 66 69 6e p-ids)))..(defin
4d10: 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 e (tasks:sync-te
4d20: 73 74 2d 67 65 6e 2d 64 61 74 61 20 64 62 68 20 st-gen-data dbh
4d30: 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 cached-info test
4d40: 2d 64 61 74 61 2d 69 64 73 20 73 6d 61 6c 6c 65 -data-ids smalle
4d50: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
4d60: 69 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 74 65 ime). (let ((te
4d70: 73 74 2d 68 74 20 28 68 61 73 68 2d 74 61 62 6c st-ht (hash-tabl
4d80: 65 2d 72 65 66 20 63 61 63 68 65 64 2d 69 6e 66 e-ref cached-inf
4d90: 6f 20 27 74 65 73 74 73 29 29 0a 20 20 20 20 20 o 'tests)).
4da0: 20 20 20 28 64 61 74 61 2d 68 74 20 28 68 61 73 (data-ht (has
4db0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 h-table-ref cach
4dc0: 65 64 2d 69 6e 66 6f 20 27 64 61 74 61 29 29 29 ed-info 'data)))
4dd0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
4de0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
4df0: 74 2d 64 61 74 61 2d 69 64 29 0a 20 20 20 20 20 t-data-id).
4e00: 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d (let* ((test-
4e10: 64 61 74 61 2d 69 6e 66 6f 20 20 28 72 6d 74 3a data-info (rmt:
4e20: 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d 62 79 get-data-info-by
4e30: 2d 69 64 20 74 65 73 74 2d 64 61 74 61 2d 69 64 -id test-data-id
4e40: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
4e50: 20 20 28 64 61 74 61 2d 69 64 20 28 64 62 3a 74 (data-id (db:t
4e60: 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 69 64 20 est-data-get-id
4e70: 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f 29 test-data-info)
4e80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4e90: 20 28 74 65 73 74 2d 69 64 20 20 28 64 62 3a 74 (test-id (db:t
4ea0: 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 65 73 est-data-get-tes
4eb0: 74 5f 69 64 20 20 20 74 65 73 74 2d 64 61 74 61 t_id test-data
4ec0: 2d 69 6e 66 6f 29 29 20 20 20 0a 09 20 20 20 20 -info)) ..
4ed0: 20 20 20 28 63 61 74 65 67 6f 72 79 20 20 28 64 (category (d
4ee0: 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d b:test-data-get-
4ef0: 63 61 74 65 67 6f 72 79 20 20 74 65 73 74 2d 64 category test-d
4f00: 61 74 61 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 ata-info))..
4f10: 20 20 20 28 76 61 72 69 61 62 6c 65 20 20 28 64 (variable (d
4f20: 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d b:test-data-get-
4f30: 76 61 72 69 61 62 6c 65 20 74 65 73 74 2d 64 61 variable test-da
4f40: 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 20 ta-info))...
4f50: 20 20 20 28 76 61 6c 75 65 20 28 64 62 3a 74 65 (value (db:te
4f60: 73 74 2d 64 61 74 61 2d 67 65 74 2d 76 61 6c 75 st-data-get-valu
4f70: 65 20 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 e test-data-inf
4f80: 6f 29 29 09 0a 20 20 20 20 20 20 20 20 20 20 20 o))..
4f90: 20 20 20 20 28 65 78 70 65 63 74 65 64 20 28 64 (expected (d
4fa0: 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d b:test-data-get-
4fb0: 65 78 70 65 63 74 65 64 20 20 74 65 73 74 2d 64 expected test-d
4fc0: 61 74 61 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 ata-info)).
4fd0: 20 20 20 20 20 20 20 20 20 20 28 74 6f 6c 20 28 (tol (
4fe0: 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 db:test-data-get
4ff0: 2d 74 6f 6c 20 20 74 65 73 74 2d 64 61 74 61 2d -tol test-data-
5000: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
5010: 20 20 20 20 20 20 28 75 6e 69 74 73 20 28 64 62 (units (db
5020: 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d 75 :test-data-get-u
5030: 6e 69 74 73 20 20 74 65 73 74 2d 64 61 74 61 2d nits test-data-
5040: 69 6e 66 6f 29 29 20 20 20 20 20 0a 09 20 20 20 info)) ..
5050: 20 20 20 20 28 63 6f 6d 6d 65 6e 74 20 20 28 64 (comment (d
5060: 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 65 74 2d b:test-data-get-
5070: 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d 64 61 74 comment test-dat
5080: 61 2d 69 6e 66 6f 29 29 09 0a 20 20 20 20 20 20 a-info))..
5090: 20 20 20 20 20 20 20 20 20 28 73 74 61 74 75 73 (status
50a0: 20 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 67 (db:test-data-g
50b0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d 64 et-status test-d
50c0: 61 74 61 2d 69 6e 66 6f 29 29 09 0a 09 20 20 20 ata-info))...
50d0: 20 20 20 20 28 74 79 70 65 20 28 64 62 3a 74 65 (type (db:te
50e0: 73 74 2d 64 61 74 61 2d 67 65 74 2d 74 79 70 65 st-data-get-type
50f0: 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f 29 test-data-info)
5100: 29 0a 09 09 09 09 20 28 6c 61 73 74 2d 75 70 64 )..... (last-upd
5110: 61 74 65 20 28 64 62 3a 74 65 73 74 2d 64 61 74 ate (db:test-dat
5120: 61 2d 67 65 74 2d 6c 61 73 74 5f 75 70 64 61 74 a-get-last_updat
5130: 65 20 74 65 73 74 2d 64 61 74 61 2d 69 6e 66 6f e test-data-info
5140: 29 29 0a 09 09 09 09 20 28 73 6d 61 6c 6c 65 73 ))..... (smalles
5150: 74 2d 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 t-time (hash-tab
5160: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 73 le-ref/default s
5170: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
5180: 61 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 ate-time "smalle
5190: 73 74 2d 74 69 6d 65 22 20 23 66 29 29 0a 20 20 st-time" #f)).
51a0: 20 09 0a 09 20 20 20 20 20 20 20 28 70 67 64 62 ... (pgdb
51b0: 2d 74 65 73 74 2d 69 64 20 20 28 68 61 73 68 2d -test-id (hash-
51c0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
51d0: 74 20 74 65 73 74 2d 68 74 20 74 65 73 74 2d 69 t test-ht test-i
51e0: 64 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 d #f)).
51f0: 20 20 20 20 20 20 28 70 67 64 62 2d 64 61 74 61 (pgdb-data
5200: 2d 69 64 20 28 69 66 20 70 67 64 62 2d 74 65 73 -id (if pgdb-tes
5210: 74 2d 69 64 20 0a 20 20 20 20 20 20 20 20 20 20 t-id .
5220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5230: 20 20 20 20 20 20 20 28 70 67 64 62 3a 67 65 74 (pgdb:get
5240: 2d 74 65 73 74 2d 64 61 74 61 2d 69 64 20 64 62 -test-data-id db
5250: 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 20 63 h pgdb-test-id c
5260: 61 74 65 67 6f 72 79 20 76 61 72 69 61 62 6c 65 ategory variable
5270: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5290: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 #f))). (i
52a0: 66 20 64 61 74 61 2d 69 64 0a 20 20 20 20 20 20 f data-id.
52b0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 (begin. (
52c0: 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 64 0a if pgdb-test-id.
52d0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
52e0: 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
52f0: 20 20 20 28 69 66 20 20 70 67 64 62 2d 64 61 74 (if pgdb-dat
5300: 61 2d 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 a-id.
5310: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
5320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5330: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5340: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
5350: 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 70 64 61 log-port* "Upda
5360: 74 69 6e 67 20 65 78 69 73 74 69 6e 67 20 74 65 ting existing te
5370: 73 74 2d 64 61 74 61 20 77 69 74 68 20 74 65 73 st-data with tes
5380: 74 2d 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 t-id: " test-id
5390: 22 20 61 6e 64 20 20 64 61 74 61 2d 69 64 20 22 " and data-id "
53a0: 20 64 61 74 61 2d 69 64 20 22 20 70 67 64 62 20 data-id " pgdb
53b0: 74 65 73 74 20 69 64 3a 20 22 20 70 67 64 62 2d test id: " pgdb-
53c0: 74 65 73 74 2d 69 64 20 22 20 70 67 64 62 20 64 test-id " pgdb d
53d0: 61 74 61 20 69 64 20 22 20 70 67 64 62 2d 64 61 ata id " pgdb-da
53e0: 74 61 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 ta-id).
53f0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
5400: 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 ((pgdb-last-upd
5410: 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d 74 65 ate (pgdb:get-te
5420: 73 74 2d 64 61 74 61 2d 6c 61 73 74 2d 75 70 64 st-data-last-upd
5430: 61 74 65 20 64 62 68 20 70 67 64 62 2d 64 61 74 ate dbh pgdb-dat
5440: 61 2d 69 64 29 29 29 0a 20 20 20 20 20 20 20 20 a-id))).
5450: 20 28 69 66 20 28 61 6e 64 20 20 28 3e 20 20 6c (if (and (> l
5460: 61 73 74 2d 75 70 64 61 74 65 20 70 67 64 62 2d ast-update pgdb-
5470: 6c 61 73 74 2d 75 70 64 61 74 65 29 20 28 6f 72 last-update) (or
5480: 20 28 6e 6f 74 20 73 6d 61 6c 6c 65 73 74 2d 74 (not smallest-t
5490: 69 6d 65 29 20 28 3c 20 6c 61 73 74 2d 75 70 64 ime) (< last-upd
54a0: 61 74 65 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d ate smallest-tim
54b0: 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 e))). (ha
54c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 6d sh-table-set! sm
54d0: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
54e0: 74 65 2d 74 69 6d 65 20 22 73 6d 61 6c 6c 65 73 te-time "smalles
54f0: 74 2d 74 69 6d 65 22 20 6c 61 73 74 2d 75 70 64 t-time" last-upd
5500: 61 74 65 29 29 29 20 0a 20 20 20 20 20 20 20 20 ate))) .
5510: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 64 (pgd
5520: 62 3a 75 70 64 61 74 65 2d 74 65 73 74 2d 64 61 b:update-test-da
5530: 74 61 20 64 62 68 20 70 67 64 62 2d 64 61 74 61 ta dbh pgdb-data
5540: 2d 69 64 20 70 67 64 62 2d 74 65 73 74 2d 69 64 -id pgdb-test-id
5550: 20 20 63 61 74 65 67 6f 72 79 20 76 61 72 69 61 category varia
5560: 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 63 74 ble value expect
5570: 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 6f 6d ed tol units com
5580: 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 70 65 ment status type
5590: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 20 last-update)).
55a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55b0: 20 20 20 28 62 65 67 69 6e 0a 20 09 09 20 20 20 (begin. ..
55c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
55d0: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
55e0: 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 49 6e 73 65 log-port* "Inse
55f0: 72 74 69 6e 67 20 74 65 73 74 2d 64 61 74 61 20 rting test-data
5600: 77 69 74 68 20 74 65 73 74 2d 69 64 3a 20 22 20 with test-id: "
5610: 74 65 73 74 2d 69 64 20 22 20 61 6e 64 20 64 61 test-id " and da
5620: 74 61 2d 69 64 20 22 20 64 61 74 61 2d 69 64 20 ta-id " data-id
5630: 22 20 70 67 64 62 20 74 65 73 74 20 69 64 3a 20 " pgdb test id:
5640: 22 20 70 67 64 62 2d 74 65 73 74 2d 69 64 29 0a " pgdb-test-id).
5650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5660: 20 20 20 20 20 20 20 28 69 66 20 28 68 61 6e 64 (if (hand
5670: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
5680: 20 20 20 20 20 20 65 78 6e 0a 09 09 20 20 20 20 exn...
5690: 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e 74 2d (begin (print-
56a0: 63 61 6c 6c 2d 63 68 61 69 6e 29 0a 20 20 20 20 call-chain).
56b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56c0: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
56d0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
56e0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
56f0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
5700: 6e 29 29 20 20 20 20 20 0a 09 09 09 23 66 29 0a n)) ....#f).
5710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5720: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
5730: 20 20 20 20 20 20 20 20 20 20 28 70 67 64 62 3a (pgdb:
5740: 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 61 74 61 insert-test-data
5750: 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 dbh pgdb-test-i
5760: 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 69 61 d category varia
5770: 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 63 74 ble value expect
5780: 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 6f 6d ed tol units com
5790: 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 70 65 ment status type
57a0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 09 last-update))..
57b0: 09 20 20 20 20 20 20 20 3b 28 74 61 73 6b 73 3a . ;(tasks:
57c0: 72 75 6e 2d 69 64 2d 3e 6d 74 70 67 2d 72 75 6e run-id->mtpg-run
57d0: 2d 69 64 20 64 62 68 20 63 61 63 68 65 64 2d 69 -id dbh cached-i
57e0: 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d nfo run-id area-
57f0: 69 6e 66 6f 29 0a 20 20 20 20 20 20 20 20 20 20 info).
5800: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
5810: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
5820: 20 20 20 20 20 20 20 20 20 3b 28 70 67 64 62 3a ;(pgdb:
5830: 69 6e 73 65 72 74 2d 74 65 73 74 2d 64 61 74 61 insert-test-data
5840: 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 dbh pgdb-test-i
5850: 64 20 63 61 74 65 67 6f 72 79 20 76 61 72 69 61 d category varia
5860: 62 6c 65 20 76 61 6c 75 65 20 65 78 70 65 63 74 ble value expect
5870: 65 64 20 74 6f 6c 20 75 6e 69 74 73 20 63 6f 6d ed tol units com
5880: 6d 65 6e 74 20 73 74 61 74 75 73 20 74 79 70 65 ment status type
5890: 20 29 0a 09 09 09 09 09 09 09 09 09 09 09 28 69 )............(i
58a0: 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c f (or (not small
58b0: 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 est-time) (< las
58c0: 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 t-update smalles
58d0: 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 t-time)).
58e0: 20 09 09 09 09 09 09 09 09 28 68 61 73 68 2d 74 ........(hash-t
58f0: 61 62 6c 65 2d 73 65 74 21 20 73 6d 61 6c 6c 65 able-set! smalle
5900: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
5910: 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 ime "smallest-ti
5920: 6d 65 22 20 6c 61 73 74 2d 75 70 64 61 74 65 29 me" last-update)
5930: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5940: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 70 67 (set! pg
5950: 64 62 2d 64 61 74 61 2d 69 64 20 20 28 70 67 64 db-data-id (pgd
5960: 62 3a 67 65 74 2d 74 65 73 74 2d 64 61 74 61 2d b:get-test-data-
5970: 69 64 20 64 62 68 20 70 67 64 62 2d 74 65 73 74 id dbh pgdb-test
5980: 2d 69 64 20 20 63 61 74 65 67 6f 72 79 20 76 61 -id category va
5990: 72 69 61 62 6c 65 29 29 29 0a 09 09 20 20 20 23 riable)))... #
59a0: 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 f))).
59b0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
59c0: 2d 73 65 74 21 20 64 61 74 61 2d 68 74 20 64 61 -set! data-ht da
59d0: 74 61 2d 69 64 20 70 67 64 62 2d 64 61 74 61 2d ta-id pgdb-data-
59e0: 69 64 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 id )).
59f0: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
5a00: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
5a10: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
5a20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5a30: 2a 20 20 22 45 72 72 6f 72 3a 20 54 65 73 74 20 * "Error: Test
5a40: 6e 6f 74 20 69 6e 20 70 67 64 62 22 29 29 29 29 not in pgdb"))))
5a50: 0a 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5a60: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 rint-info 1 *def
5a70: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 ault-log-port*
5a80: 22 45 72 72 6f 72 3a 20 43 6f 75 6c 64 20 6e 6f "Error: Could no
5a90: 74 20 67 65 74 20 74 65 73 74 20 64 61 74 61 20 t get test data
5aa0: 69 6e 66 6f 20 66 6f 72 20 64 61 74 61 20 69 64 info for data id
5ab0: 20 22 20 74 65 73 74 2d 64 61 74 61 2d 69 64 20 " test-data-id
5ac0: 29 29 29 29 09 3b 3b 20 74 68 69 73 20 69 73 20 )))).;; this is
5ad0: 61 20 77 69 65 72 64 20 73 65 6e 61 72 69 6f 20 a wierd senario
5ae0: 6e 65 65 64 20 74 6f 20 64 65 62 75 67 20 20 20 need to debug
5af0: 20 20 20 09 0a 20 20 20 74 65 73 74 2d 64 61 74 .. test-dat
5b00: 61 2d 69 64 73 29 29 29 0a 0a 0a 0a 28 64 65 66 a-ids)))....(def
5b10: 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d ine (tasks:sync-
5b20: 74 65 73 74 73 2d 64 61 74 61 20 64 62 68 20 63 tests-data dbh c
5b30: 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 2d ached-info test-
5b40: 69 64 73 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d ids area-info sm
5b50: 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 allest-last-upda
5b60: 74 65 2d 74 69 6d 65 29 0a 20 20 28 6c 65 74 20 te-time). (let
5b70: 28 28 74 65 73 74 2d 68 74 20 28 68 61 73 68 2d ((test-ht (hash-
5b80: 74 61 62 6c 65 2d 72 65 66 20 63 61 63 68 65 64 table-ref cached
5b90: 2d 69 6e 66 6f 20 27 74 65 73 74 73 29 29 29 0a -info 'tests))).
5ba0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
5bb0: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
5bc0: 2d 69 64 29 0a 20 20 20 20 20 20 3b 20 28 70 72 -id). ; (pr
5bd0: 69 6e 74 20 74 65 73 74 2d 69 64 29 0a 20 20 20 int test-id).
5be0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
5bf0: 2d 69 6e 66 6f 20 20 20 20 28 72 6d 74 3a 67 65 -info (rmt:ge
5c00: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
5c10: 64 20 23 66 20 74 65 73 74 2d 69 64 29 29 0a 09 d #f test-id))..
5c20: 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 20 20 (run-id
5c30: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
5c40: 2d 72 75 6e 5f 69 64 20 20 20 20 74 65 73 74 2d -run_id test-
5c50: 69 6e 66 6f 29 29 20 3b 3b 20 6c 6f 6f 6b 20 74 info)) ;; look t
5c60: 68 65 73 65 20 75 70 20 69 6e 20 64 62 5f 72 65 hese up in db_re
5c70: 63 6f 72 64 73 2e 73 63 6d 0a 09 20 20 20 20 20 cords.scm..
5c80: 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 28 (test-id (
5c90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 20 db:test-get-id
5ca0: 20 20 20 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 test-info)
5cb0: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 6e ).. (test-n
5cc0: 61 6d 65 20 20 20 20 28 64 62 3a 74 65 73 74 2d ame (db:test-
5cd0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 get-testname te
5ce0: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
5cf0: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 28 (item-path (
5d00: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
5d10: 2d 70 61 74 68 20 74 65 73 74 2d 69 6e 66 6f 29 -path test-info)
5d20: 29 0a 09 20 20 20 20 20 20 28 73 74 61 74 65 20 ).. (state
5d30: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
5d40: 67 65 74 2d 73 74 61 74 65 20 20 20 20 20 74 65 get-state te
5d50: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
5d60: 20 28 73 74 61 74 75 73 20 20 20 20 20 20 20 28 (status (
5d70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
5d80: 75 73 20 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 us test-info)
5d90: 29 0a 09 20 20 20 20 20 20 28 68 6f 73 74 20 20 ).. (host
5da0: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
5db0: 67 65 74 2d 68 6f 73 74 20 20 20 20 20 20 74 65 get-host te
5dc0: 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 st-info)).
5dd0: 20 20 28 70 69 64 20 20 20 20 20 20 20 20 20 20 (pid
5de0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 70 72 6f (db:test-get-pro
5df0: 63 65 73 73 5f 69 64 20 74 65 73 74 2d 69 6e 66 cess_id test-inf
5e00: 6f 29 29 20 0a 09 20 20 20 20 20 20 28 63 70 75 o)) .. (cpu
5e10: 6c 6f 61 64 20 20 20 20 20 20 28 64 62 3a 74 65 load (db:te
5e20: 73 74 2d 67 65 74 2d 63 70 75 6c 6f 61 64 20 20 st-get-cpuload
5e30: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
5e40: 20 20 20 20 28 64 69 73 6b 66 72 65 65 20 20 20 (diskfree
5e50: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 64 (db:test-get-d
5e60: 69 73 6b 66 72 65 65 20 20 74 65 73 74 2d 69 6e iskfree test-in
5e70: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 75 6e 61 fo)).. (una
5e80: 6d 65 20 20 20 20 20 20 20 20 28 64 62 3a 74 65 me (db:te
5e90: 73 74 2d 67 65 74 2d 75 6e 61 6d 65 20 20 20 20 st-get-uname
5ea0: 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 test-info))..
5eb0: 20 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 20 (run-dir
5ec0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
5ed0: 75 6e 64 69 72 20 20 20 20 74 65 73 74 2d 69 6e undir test-in
5ee0: 66 6f 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 67 fo)).. (log
5ef0: 2d 66 69 6c 65 20 20 20 20 20 28 64 62 3a 74 65 -file (db:te
5f00: 73 74 2d 67 65 74 2d 66 69 6e 61 6c 5f 6c 6f 67 st-get-final_log
5f10: 66 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 f test-info))..
5f20: 20 20 20 20 20 28 72 75 6e 2d 64 75 72 61 74 69 (run-durati
5f30: 6f 6e 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d on (db:test-get-
5f40: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 run_duration tes
5f50: 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 t-info))..
5f60: 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 28 64 (comment (d
5f70: 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 b:test-get-comme
5f80: 6e 74 20 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 nt test-info))
5f90: 0a 09 20 20 20 20 20 20 28 65 76 65 6e 74 2d 74 .. (event-t
5fa0: 69 6d 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 ime (db:test-g
5fb0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 et-event_time te
5fc0: 73 74 2d 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 st-info))..
5fd0: 20 28 61 72 63 68 69 76 65 64 20 20 20 20 20 28 (archived (
5fe0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 61 72 63 68 db:test-get-arch
5ff0: 69 76 65 64 20 20 74 65 73 74 2d 69 6e 66 6f 29 ived test-info)
6000: 29 0a 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d ). (last-
6010: 75 70 64 61 74 65 20 20 28 64 62 3a 74 65 73 74 update (db:test
6020: 2d 67 65 74 2d 6c 61 73 74 5f 75 70 64 61 74 65 -get-last_update
6030: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 20 test-info))..
6040: 20 20 20 20 20 28 70 67 64 62 2d 72 75 6e 2d 69 (pgdb-run-i
6050: 64 20 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 64 d (tasks:run-id
6060: 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 62 ->mtpg-run-id db
6070: 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 75 h cached-info ru
6080: 6e 2d 69 64 20 61 72 65 61 2d 69 6e 66 6f 20 73 n-id area-info s
6090: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
60a0: 61 74 65 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 ate-time)).
60b0: 20 20 20 28 73 6d 61 6c 6c 65 73 74 2d 74 69 6d (smallest-tim
60c0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
60d0: 66 2f 64 65 66 61 75 6c 74 20 73 6d 61 6c 6c 65 f/default smalle
60e0: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
60f0: 69 6d 65 20 22 73 6d 61 6c 6c 65 73 74 2d 74 69 ime "smallest-ti
6100: 6d 65 22 20 23 66 29 29 20 20 20 20 20 20 20 0a me" #f)) .
6110: 09 20 20 20 20 20 20 28 70 67 64 62 2d 74 65 73 . (pgdb-tes
6120: 74 2d 69 64 20 28 69 66 20 70 67 64 62 2d 72 75 t-id (if pgdb-ru
6130: 6e 2d 69 64 20 0a 09 09 09 09 28 62 65 67 69 6e n-id .....(begin
6140: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6160: 20 20 20 3b 28 70 72 69 6e 74 20 70 67 64 62 2d ;(print pgdb-
6170: 72 75 6e 2d 69 64 29 20 20 20 20 0a 20 20 20 20 run-id) .
6180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6190: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 67 (pg
61a0: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 db:get-test-id d
61b0: 62 68 20 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 bh pgdb-run-id t
61c0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
61d0: 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 th)).
61e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61f0: 20 20 20 20 20 20 23 66 29 29 29 0a 09 20 3b 3b #f))).. ;;
6200: 20 22 69 64 22 20 20 20 20 20 20 20 20 20 20 20 "id"
6210: 22 72 75 6e 5f 69 64 22 20 20 20 20 20 20 20 20 "run_id"
6220: 22 74 65 73 74 6e 61 6d 65 22 20 20 22 73 74 61 "testname" "sta
6230: 74 65 22 20 20 20 20 20 20 22 73 74 61 74 75 73 te" "status
6240: 22 20 20 20 20 20 20 22 65 76 65 6e 74 5f 74 69 " "event_ti
6250: 6d 65 22 0a 09 20 3b 3b 20 22 68 6f 73 74 22 20 me".. ;; "host"
6260: 20 20 20 20 20 20 20 20 22 63 70 75 6c 6f 61 64 "cpuload
6270: 22 20 20 20 20 20 20 20 22 64 69 73 6b 66 72 65 " "diskfre
6280: 65 22 20 20 22 75 6e 61 6d 65 22 20 20 20 20 20 e" "uname"
6290: 20 22 72 75 6e 64 69 72 22 20 20 20 20 20 20 22 "rundir" "
62a0: 69 74 65 6d 5f 70 61 74 68 22 0a 09 20 3b 3b 20 item_path".. ;;
62b0: 22 72 75 6e 5f 64 75 72 61 74 69 6f 6e 22 20 22 "run_duration" "
62c0: 66 69 6e 61 6c 5f 6c 6f 67 66 22 20 20 20 20 22 final_logf" "
62d0: 63 6f 6d 6d 65 6e 74 22 20 20 20 22 73 68 6f 72 comment" "shor
62e0: 74 64 69 72 22 20 20 20 22 61 74 74 65 6d 70 74 tdir" "attempt
62f0: 6e 75 6d 22 20 20 22 61 72 63 68 69 76 65 64 22 num" "archived"
6300: 0a 20 20 20 20 20 20 20 20 20 28 69 66 20 70 67 . (if pg
6310: 64 62 2d 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 db-run-id.
6320: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
6330: 28 69 66 20 70 67 64 62 2d 74 65 73 74 2d 69 64 (if pgdb-test-id
6340: 20 3b 3b 20 68 61 76 65 20 61 20 72 65 63 6f 72 ;; have a recor
6350: 64 0a 09 20 20 20 20 20 28 62 65 67 69 6e 20 3b d.. (begin ;
6360: 3b 20 6c 65 74 20 28 28 6b 65 79 2d 6e 61 6d 65 ; let ((key-name
6370: 20 28 63 6f 6e 63 20 72 75 6e 2d 69 64 20 22 2f (conc run-id "/
6380: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
6390: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 item-path)))..
63a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
63b0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
63c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 55 70 t-log-port* "Up
63d0: 64 61 74 69 6e 67 20 65 78 69 73 74 69 6e 67 20 dating existing
63e0: 74 65 73 74 20 77 69 74 68 20 72 75 6e 2d 69 64 test with run-id
63f0: 3a 20 22 20 72 75 6e 2d 69 64 20 22 20 61 6e 64 : " run-id " and
6400: 20 74 65 73 74 2d 69 64 3a 20 22 20 74 65 73 74 test-id: " test
6410: 2d 69 64 20 22 20 70 67 64 62 20 72 75 6e 20 69 -id " pgdb run i
6420: 64 3a 20 22 20 70 67 64 62 2d 72 75 6e 2d 69 64 d: " pgdb-run-id
6430: 20 22 20 20 70 67 64 62 2d 74 65 73 74 2d 69 64 " pgdb-test-id
6440: 20 22 20 20 70 67 64 62 2d 74 65 73 74 2d 69 64 " pgdb-test-id
6450: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a ). (let*
6460: 20 28 28 70 67 64 62 2d 6c 61 73 74 2d 75 70 64 ((pgdb-last-upd
6470: 61 74 65 20 28 70 67 64 62 3a 67 65 74 2d 74 65 ate (pgdb:get-te
6480: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 64 st-last-update d
6490: 62 68 20 70 67 64 62 2d 74 65 73 74 2d 69 64 29 bh pgdb-test-id)
64a0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 20 )). (if
64b0: 28 61 6e 64 20 20 28 3e 20 20 6c 61 73 74 2d 75 (and (> last-u
64c0: 70 64 61 74 65 20 70 67 64 62 2d 6c 61 73 74 2d pdate pgdb-last-
64d0: 75 70 64 61 74 65 29 20 28 6f 72 20 28 6e 6f 74 update) (or (not
64e0: 20 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 20 smallest-time)
64f0: 28 3c 20 6c 61 73 74 2d 75 70 64 61 74 65 20 73 (< last-update s
6500: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 29 29 29 20 mallest-time)))
6510: 3b 3b 69 66 20 6c 61 73 74 2d 75 70 64 61 74 65 ;;if last-update
6520: 20 69 73 20 73 61 6d 65 20 61 73 20 70 67 64 62 is same as pgdb
6530: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 74 68 65 -last-update the
6540: 6e 20 69 74 20 69 73 20 73 61 66 65 20 74 6f 20 n it is safe to
6550: 61 73 73 75 6d 65 20 74 68 65 20 72 65 63 6f 72 assume the recor
6560: 64 73 20 61 72 65 20 69 64 65 6e 74 69 63 61 6c ds are identical
6570: 20 61 6e 64 20 77 65 20 63 61 6e 20 75 73 65 20 and we can use
6580: 61 20 6c 61 72 67 65 72 20 6c 61 73 74 20 75 70 a larger last up
6590: 64 61 74 65 20 74 69 6d 65 2e 0a 20 20 20 20 20 date time..
65a0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
65b0: 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 et! smallest-las
65c0: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 t-update-time "s
65d0: 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 6c 61 mallest-time" la
65e0: 73 74 2d 75 70 64 61 74 65 29 29 29 20 0a 09 20 st-update))) ..
65f0: 20 20 20 20 20 20 28 70 67 64 62 3a 75 70 64 61 (pgdb:upda
6600: 74 65 2d 74 65 73 74 20 64 62 68 20 70 67 64 62 te-test dbh pgdb
6610: 2d 74 65 73 74 2d 69 64 20 70 67 64 62 2d 72 75 -test-id pgdb-ru
6620: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
6630: 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 tem-path state s
6640: 74 61 74 75 73 20 68 6f 73 74 20 63 70 75 6c 6f tatus host cpulo
6650: 61 64 20 64 69 73 6b 66 72 65 65 20 75 6e 61 6d ad diskfree unam
6660: 65 20 72 75 6e 2d 64 69 72 20 6c 6f 67 2d 66 69 e run-dir log-fi
6670: 6c 65 20 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 le run-duration
6680: 63 6f 6d 6d 65 6e 74 20 65 76 65 6e 74 2d 74 69 comment event-ti
6690: 6d 65 20 61 72 63 68 69 76 65 64 20 6c 61 73 74 me archived last
66a0: 2d 75 70 64 61 74 65 20 70 69 64 29 29 0a 09 20 -update pid))..
66b0: 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 (begin .
66c0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
66d0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
66e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 ult-log-port* "
66f0: 49 6e 73 65 72 74 69 6e 67 20 74 65 73 74 20 77 Inserting test w
6700: 69 74 68 20 72 75 6e 2d 69 64 3a 20 22 20 72 75 ith run-id: " ru
6710: 6e 2d 69 64 20 22 20 61 6e 64 20 74 65 73 74 2d n-id " and test-
6720: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 20 22 id: " test-id "
6730: 20 70 67 64 62 20 72 75 6e 20 69 64 3a 20 22 20 pgdb run id: "
6740: 70 67 64 62 2d 72 75 6e 2d 69 64 29 0a 20 20 20 pgdb-run-id).
6750: 20 20 20 20 20 20 20 20 28 70 67 64 62 3a 69 6e (pgdb:in
6760: 73 65 72 74 2d 74 65 73 74 20 64 62 68 20 70 67 sert-test dbh pg
6770: 64 62 2d 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db-run-id test-n
6780: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 ame item-path st
6790: 61 74 65 20 73 74 61 74 75 73 20 68 6f 73 74 20 ate status host
67a0: 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
67b0: 20 75 6e 61 6d 65 20 72 75 6e 2d 64 69 72 20 6c uname run-dir l
67c0: 6f 67 2d 66 69 6c 65 20 72 75 6e 2d 64 75 72 61 og-file run-dura
67d0: 74 69 6f 6e 20 63 6f 6d 6d 65 6e 74 20 65 76 65 tion comment eve
67e0: 6e 74 2d 74 69 6d 65 20 61 72 63 68 69 76 65 64 nt-time archived
67f0: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 70 69 64 last-update pid
6800: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
6810: 66 20 28 6f 72 20 28 6e 6f 74 20 73 6d 61 6c 6c f (or (not small
6820: 65 73 74 2d 74 69 6d 65 29 20 28 3c 20 6c 61 73 est-time) (< las
6830: 74 2d 75 70 64 61 74 65 20 73 6d 61 6c 6c 65 73 t-update smalles
6840: 74 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 t-time)).
6850: 20 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ....(hash-table
6860: 2d 73 65 74 21 20 73 6d 61 6c 6c 65 73 74 2d 6c -set! smallest-l
6870: 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 ast-update-time
6880: 22 73 6d 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 "smallest-time"
6890: 6c 61 73 74 2d 75 70 64 61 74 65 29 29 0a 20 20 last-update)).
68a0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 70 (set! p
68b0: 67 64 62 2d 74 65 73 74 2d 69 64 20 28 70 67 64 gdb-test-id (pgd
68c0: 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 b:get-test-id db
68d0: 68 20 70 67 64 62 2d 72 75 6e 2d 69 64 20 74 65 h pgdb-run-id te
68e0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
68f0: 68 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 h)))).
6900: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
6910: 21 20 74 65 73 74 2d 68 74 20 74 65 73 74 2d 69 ! test-ht test-i
6920: 64 20 70 67 64 62 2d 74 65 73 74 2d 69 64 29 29 d pgdb-test-id))
6930: 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 . (deb
6940: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
6950: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6960: 74 2a 20 20 22 57 41 52 4e 49 4e 47 3a 20 53 6b t* "WARNING: Sk
6970: 69 70 70 69 6e 67 20 72 75 6e 20 77 69 74 68 20 ipping run with
6980: 72 75 6e 2d 69 64 3a 22 20 72 75 6e 2d 69 64 20 run-id:" run-id
6990: 22 2e 20 54 68 69 73 20 72 75 6e 20 77 61 73 20 ". This run was
69a0: 63 72 65 61 74 65 64 20 61 66 74 65 72 20 70 72 created after pr
69b0: 69 76 69 6f 75 73 20 73 79 6e 63 20 61 6e 64 20 ivious sync and
69c0: 72 65 6d 6f 76 65 64 20 62 65 66 6f 72 65 20 74 removed before t
69d0: 68 69 73 20 73 79 6e 63 2e 22 29 29 29 29 0a 20 his sync.")))).
69e0: 20 20 20 20 74 65 73 74 2d 69 64 73 29 29 29 0a test-ids))).
69f0: 0a 28 64 65 66 69 6e 65 20 28 74 61 73 6b 3a 61 .(define (task:a
6a00: 64 64 2d 61 72 65 61 2d 74 61 67 20 64 62 68 20 dd-area-tag dbh
6a10: 61 72 65 61 2d 69 6e 66 6f 20 74 61 67 29 20 0a area-info tag) .
6a20: 20 20 28 6c 65 74 2a 20 28 28 74 61 67 2d 69 6e (let* ((tag-in
6a30: 66 6f 20 28 70 67 64 62 3a 67 65 74 2d 74 61 67 fo (pgdb:get-tag
6a40: 2d 69 6e 66 6f 2d 62 79 2d 6e 61 6d 65 20 64 62 -info-by-name db
6a50: 68 20 74 61 67 29 29 29 0a 20 20 20 28 69 66 20 h tag))). (if
6a60: 28 6e 6f 74 20 74 61 67 2d 69 6e 66 6f 29 0a 20 (not tag-info).
6a70: 20 20 20 20 28 62 65 67 69 6e 20 20 20 0a 20 20 (begin .
6a80: 20 20 20 28 69 66 20 28 68 61 6e 64 6c 65 2d 65 (if (handle-e
6a90: 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 xceptions.. ex
6aa0: 6e 0a 09 20 20 20 28 62 65 67 69 6e 20 0a 20 20 n.. (begin .
6ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
6ac0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
6ad0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6ae0: 72 74 2a 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e rt* ((condition
6af0: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
6b00: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
6b10: 29 20 65 78 6e 29 29 20 20 20 20 20 0a 09 20 20 ) exn)) ..
6b20: 20 23 66 29 0a 09 20 20 20 28 70 67 64 62 3a 69 #f).. (pgdb:i
6b30: 6e 73 65 72 74 2d 74 61 67 20 20 64 62 68 20 20 nsert-tag dbh
6b40: 20 74 61 67 29 29 0a 20 20 20 20 20 20 20 20 20 tag)).
6b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
6b60: 65 74 21 20 74 61 67 2d 69 6e 66 6f 20 28 70 67 et! tag-info (pg
6b70: 64 62 3a 67 65 74 2d 74 61 67 2d 69 6e 66 6f 2d db:get-tag-info-
6b80: 62 79 2d 6e 61 6d 65 20 64 62 68 20 74 61 67 29 by-name dbh tag)
6b90: 29 0a 09 09 20 20 23 66 29 29 29 0a 20 20 20 20 )... #f))).
6ba0: 20 3b 3b 61 64 64 20 74 6f 20 61 72 65 61 5f 74 ;;add to area_t
6bb0: 61 67 73 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 ags. (handle
6bc0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 -exceptions..
6bd0: 65 78 6e 0a 09 20 20 20 28 62 65 67 69 6e 20 0a exn.. (begin .
6be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6bf0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6c00: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
6c10: 70 6f 72 74 2a 20 20 28 28 63 6f 6e 64 69 74 69 port* ((conditi
6c20: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
6c30: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
6c40: 67 65 29 20 65 78 6e 29 29 20 20 20 20 20 0a 09 ge) exn)) ..
6c50: 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
6c60: 20 20 28 69 66 20 28 6e 6f 74 20 28 70 67 64 62 (if (not (pgdb
6c70: 3a 69 73 2d 61 72 65 61 2d 74 61 67 65 64 2d 77 :is-area-taged-w
6c80: 69 74 68 2d 61 2d 74 61 67 20 64 62 68 20 28 76 ith-a-tag dbh (v
6c90: 65 63 74 6f 72 2d 72 65 66 20 74 61 67 2d 69 6e ector-ref tag-in
6ca0: 66 6f 20 30 29 20 20 28 76 65 63 74 6f 72 2d 72 fo 0) (vector-r
6cb0: 65 66 20 61 72 65 61 2d 69 6e 66 6f 20 30 29 29 ef area-info 0))
6cc0: 29 20 20 0a 09 20 20 20 28 70 67 64 62 3a 69 6e ) .. (pgdb:in
6cd0: 73 65 72 74 2d 61 72 65 61 2d 74 61 67 20 20 64 sert-area-tag d
6ce0: 62 68 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 bh (vector-ref
6cf0: 20 74 61 67 2d 69 6e 66 6f 20 30 29 20 20 28 76 tag-info 0) (v
6d00: 65 63 74 6f 72 2d 72 65 66 20 61 72 65 61 2d 69 ector-ref area-i
6d10: 6e 66 6f 20 30 29 29 29 29 29 29 0a 0a 28 64 65 nfo 0))))))..(de
6d20: 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 6e 63 fine (tasks:sync
6d30: 2d 72 75 6e 2d 64 61 74 61 20 64 62 68 20 63 61 -run-data dbh ca
6d40: 63 68 65 64 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 ched-info run-id
6d50: 73 20 61 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c s area-info smal
6d60: 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 lest-last-update
6d70: 2d 74 69 6d 65 29 20 0a 20 20 28 66 6f 72 2d 65 -time) . (for-e
6d80: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
6d90: 20 28 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 (run-id).
6da0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6db0: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
6dc0: 2d 70 6f 72 74 2a 20 20 20 22 43 68 65 63 6b 20 -port* "Check
6dd0: 69 66 20 72 75 6e 20 77 69 74 68 20 22 20 72 75 if run with " ru
6de0: 6e 2d 69 64 20 22 20 6e 65 65 64 73 20 74 6f 20 n-id " needs to
6df0: 62 65 20 73 79 6e 63 65 64 22 20 29 0a 20 20 20 be synced" ).
6e00: 20 20 20 20 28 74 61 73 6b 73 3a 72 75 6e 2d 69 (tasks:run-i
6e10: 64 2d 3e 6d 74 70 67 2d 72 75 6e 2d 69 64 20 64 d->mtpg-run-id d
6e20: 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 bh cached-info r
6e30: 75 6e 2d 69 64 20 61 72 65 61 2d 69 6e 66 6f 20 un-id area-info
6e40: 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 smallest-last-up
6e50: 64 61 74 65 2d 74 69 6d 65 29 29 0a 72 75 6e 2d date-time)).run-
6e60: 69 64 73 29 29 0a 0a 0a 3b 3b 20 67 65 74 20 72 ids))...;; get r
6e70: 75 6e 73 20 63 68 61 6e 67 65 64 20 73 69 6e 63 uns changed sinc
6e80: 65 20 6c 61 73 74 20 73 79 6e 63 0a 3b 3b 20 28 e last sync.;; (
6e90: 64 65 66 69 6e 65 20 28 74 61 73 6b 73 3a 73 79 define (tasks:sy
6ea0: 6e 63 2d 74 65 73 74 2d 64 61 74 61 20 64 62 68 nc-test-data dbh
6eb0: 20 63 61 63 68 65 64 2d 69 6e 66 6f 20 61 72 65 cached-info are
6ec0: 61 2d 69 6e 66 6f 29 0a 3b 3b 20 20 20 28 6c 65 a-info).;; (le
6ed0: 74 2a 20 28 28 0a 0a 28 64 65 66 69 6e 65 20 28 t* ((..(define (
6ee0: 74 61 73 6b 73 3a 73 79 6e 63 2d 74 6f 2d 70 6f tasks:sync-to-po
6ef0: 73 74 67 72 65 73 20 63 6f 6e 66 69 67 64 61 74 stgres configdat
6f00: 20 64 65 73 74 29 0a 20 20 28 70 72 69 6e 74 20 dest). (print
6f10: 22 49 6e 20 73 79 6e 63 22 29 0a 20 20 28 6c 65 "In sync"). (le
6f20: 74 2a 20 28 28 64 62 68 20 20 20 20 20 20 20 20 t* ((dbh
6f30: 20 28 70 67 64 62 3a 6f 70 65 6e 20 63 6f 6e 66 (pgdb:open conf
6f40: 69 67 64 61 74 20 64 62 6e 61 6d 65 3a 20 64 65 igdat dbname: de
6f50: 73 74 29 29 0a 09 20 28 61 72 65 61 2d 69 6e 66 st)).. (area-inf
6f60: 6f 20 20 20 28 70 67 64 62 3a 67 65 74 2d 61 72 o (pgdb:get-ar
6f70: 65 61 2d 62 79 2d 70 61 74 68 20 64 62 68 20 2a ea-by-path dbh *
6f80: 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 28 63 61 toppath*)).. (ca
6f90: 63 68 65 64 2d 69 6e 66 6f 20 28 6d 61 6b 65 2d ched-info (make-
6fa0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 hash-table)).. (
6fb0: 73 74 61 72 74 20 20 20 20 20 20 20 28 63 75 72 start (cur
6fc0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 rent-seconds)).
6fd0: 20 20 28 74 65 73 74 2d 70 61 74 74 20 20 20 28 (test-patt (
6fe0: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
6ff0: 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a 09 09 "-testpatt")...
7000: 09 09 09 09 09 09 09 09 09 28 61 72 67 73 3a 67 .........(args:g
7010: 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 et-arg "-testpat
7020: 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t").
7030: 20 20 20 20 20 20 20 20 20 20 22 25 22 29 29 0a "%")).
7040: 20 20 20 28 74 61 72 67 65 74 20 20 20 20 20 20 (target
7050: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
7060: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
7070: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 20 28 .............. (
7080: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
7090: 61 72 67 65 74 22 29 0a 09 09 09 09 09 09 09 09 arget").........
70a0: 09 09 09 09 09 23 66 29 29 0a 20 20 20 20 28 72 .....#f)). (r
70b0: 75 6e 2d 6e 61 6d 65 20 20 20 20 20 20 20 20 20 un-name
70c0: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
70d0: 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 g "-runname")...
70e0: 09 09 09 09 09 09 09 09 09 09 09 09 20 28 61 72 ............ (ar
70f0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
7100: 6e 61 6d 65 22 29 0a 09 09 09 09 09 09 09 09 09 name")..........
7110: 09 09 09 09 23 66 29 29 29 0a 20 20 20 20 20 28 ....#f))). (
7120: 69 66 20 28 61 6e 64 20 74 61 72 67 65 74 20 20 if (and target
7130: 28 6e 6f 74 20 72 75 6e 2d 6e 61 6d 65 29 29 0a (not run-name)).
7140: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
7150: 09 09 09 28 70 72 69 6e 74 20 22 45 72 72 6f 72 ...(print "Error
7160: 3a 20 50 72 6f 76 69 64 65 20 72 75 6e 6e 61 6d : Provide runnam
7170: 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 e"). (e
7180: 78 69 74 20 31 29 29 29 0a 20 20 20 20 20 28 69 xit 1))). (i
7190: 66 20 28 61 6e 64 20 28 6e 6f 74 20 74 61 72 67 f (and (not targ
71a0: 65 74 29 20 20 72 75 6e 2d 6e 61 6d 65 29 0a 20 et) run-name).
71b0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
71c0: 09 09 28 70 72 69 6e 74 20 22 45 72 72 6f 72 3a ..(print "Error:
71d0: 20 50 72 6f 76 69 64 65 20 74 61 72 67 65 74 22 Provide target"
71e0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 78 69 ). (exi
71f0: 74 20 31 29 29 29 0a 20 20 20 20 3b 28 70 72 69 t 1))). ;(pri
7200: 6e 74 20 22 31 32 33 22 29 0a 20 20 20 20 3b 28 nt "123"). ;(
7210: 65 78 69 74 20 31 29 20 0a 20 20 20 20 28 66 6f exit 1) . (fo
7220: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
7230: 64 74 79 70 65 29 0a 09 09 28 68 61 73 68 2d 74 dtype)...(hash-t
7240: 61 62 6c 65 2d 73 65 74 21 20 63 61 63 68 65 64 able-set! cached
7250: 2d 69 6e 66 6f 20 64 74 79 70 65 20 28 6d 61 6b -info dtype (mak
7260: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
7270: 09 20 20 20 20 20 20 27 28 72 75 6e 73 20 74 61 . '(runs ta
7280: 72 67 65 74 73 20 74 65 73 74 73 20 73 74 65 70 rgets tests step
7290: 73 20 64 61 74 61 29 29 0a 20 20 20 20 28 68 61 s data)). (ha
72a0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 61 sh-table-set! ca
72b0: 63 68 65 64 2d 69 6e 66 6f 20 27 73 74 61 72 74 ched-info 'start
72c0: 20 73 74 61 72 74 29 20 3b 3b 20 77 68 65 6e 20 start) ;; when
72d0: 64 6f 6e 65 20 77 65 27 6c 6c 20 73 65 74 20 73 done we'll set s
72e0: 79 6e 63 20 74 69 6d 65 73 20 74 6f 20 74 68 69 ync times to thi
72f0: 73 0a 20 20 20 20 28 69 66 20 61 72 65 61 2d 69 s. (if area-i
7300: 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 6c 61 73 nfo..(let* ((las
7310: 74 2d 73 79 6e 63 2d 74 69 6d 65 20 28 76 65 63 t-sync-time (vec
7320: 74 6f 72 2d 72 65 66 20 61 72 65 61 2d 69 6e 66 tor-ref area-inf
7330: 6f 20 33 29 29 0a 09 20 20 20 20 20 20 20 28 73 o 3)).. (s
7340: 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d 75 70 64 mallest-last-upd
7350: 61 74 65 2d 74 69 6d 65 20 20 28 6d 61 6b 65 2d ate-time (make-
7360: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 hash-table)).
7370: 20 20 20 20 20 20 28 63 68 61 6e 67 65 64 20 20 (changed
7380: 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 61 72 (if (and tar
7390: 67 65 74 20 72 75 6e 2d 6e 61 6d 65 29 0a 20 20 get run-name).
73a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73b0: 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 (rmt:g
73c0: 65 74 2d 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 et-run-record-id
73d0: 73 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d s target run-nam
73e0: 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 e (rmt:get-keys)
73f0: 20 74 65 73 74 2d 70 61 74 74 29 0a 20 20 20 20 test-patt).
7400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7410: 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 (rmt:get
7420: 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d -changed-record-
7430: 69 64 73 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 ids last-sync-ti
7440: 6d 65 29 29 29 0a 09 20 20 20 20 20 20 20 28 72 me))).. (r
7450: 75 6e 2d 69 64 73 20 20 20 20 20 20 20 20 28 61 un-ids (a
7460: 6c 69 73 74 2d 72 65 66 20 27 72 75 6e 73 20 20 list-ref 'runs
7470: 20 20 20 20 20 63 68 61 6e 67 65 64 29 29 0a 09 changed))..
7480: 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 73 (test-ids
7490: 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 (alist-re
74a0: 66 20 27 74 65 73 74 73 20 20 20 20 20 20 63 68 f 'tests ch
74b0: 61 6e 67 65 64 29 29 0a 09 20 20 20 20 20 20 20 anged))..
74c0: 28 74 65 73 74 2d 73 74 65 70 2d 69 64 73 20 20 (test-step-ids
74d0: 28 61 6c 69 73 74 2d 72 65 66 20 27 74 65 73 74 (alist-ref 'test
74e0: 5f 73 74 65 70 73 20 63 68 61 6e 67 65 64 29 29 _steps changed))
74f0: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 .. (test-d
7500: 61 74 61 2d 69 64 73 20 20 28 61 6c 69 73 74 2d ata-ids (alist-
7510: 72 65 66 20 27 74 65 73 74 5f 64 61 74 61 20 20 ref 'test_data
7520: 63 68 61 6e 67 65 64 29 29 0a 09 20 20 20 20 20 changed))..
7530: 20 20 28 72 75 6e 2d 73 74 61 74 2d 69 64 73 20 (run-stat-ids
7540: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 (alist-ref 'ru
7550: 6e 5f 73 74 61 74 73 20 20 63 68 61 6e 67 65 64 n_stats changed
7560: 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 )). (are
7570: 61 2d 74 61 67 20 20 20 20 28 69 66 20 28 61 72 a-tag (if (ar
7580: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 65 gs:get-arg "-are
7590: 61 2d 74 61 67 22 29 20 0a 20 20 20 20 20 20 20 a-tag") .
75a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
75b0: 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a (args:
75c0: 67 65 74 2d 61 72 67 20 22 2d 61 72 65 61 2d 74 get-arg "-area-t
75d0: 61 67 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ag").
75e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
75f0: 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a (if (args:
7600: 67 65 74 2d 61 72 67 20 22 2d 61 72 65 61 22 29 get-arg "-area")
7610: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7630: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
7640: 72 67 20 22 2d 61 72 65 61 22 29 20 0a 20 20 20 rg "-area") .
7650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7670: 22 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 "")))).
7680: 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 (if (and (equa
7690: 6c 3f 20 61 72 65 61 2d 74 61 67 20 22 22 29 20 l? area-tag "")
76a0: 28 6e 6f 74 20 28 70 67 64 62 3a 69 73 2d 61 72 (not (pgdb:is-ar
76b0: 65 61 2d 74 61 67 65 64 20 64 62 68 20 28 76 65 ea-taged dbh (ve
76c0: 63 74 6f 72 2d 72 65 66 20 61 72 65 61 2d 69 6e ctor-ref area-in
76d0: 66 6f 20 30 29 29 29 29 0a 20 20 20 20 20 20 20 fo 0)))).
76e0: 20 20 20 20 20 28 73 65 74 21 20 61 72 65 61 2d (set! area-
76f0: 74 61 67 20 2a 64 65 66 61 75 6c 74 2d 61 72 65 tag *default-are
7700: 61 2d 74 61 67 2a 29 29 20 0a 20 20 20 20 20 20 a-tag*)) .
7710: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
7720: 71 75 61 6c 3f 20 61 72 65 61 2d 74 61 67 20 22 qual? area-tag "
7730: 22 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ")) .
7740: 20 20 28 74 61 73 6b 3a 61 64 64 2d 61 72 65 61 (task:add-area
7750: 2d 74 61 67 20 64 62 68 20 61 72 65 61 2d 69 6e -tag dbh area-in
7760: 66 6f 20 61 72 65 61 2d 74 61 67 29 29 20 0a 09 fo area-tag)) ..
7770: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
7780: 6e 75 6c 6c 3f 20 74 65 73 74 2d 69 64 73 29 29 null? test-ids))
7790: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 75 6e (not (null? run
77a0: 2d 69 64 73 29 29 29 0a 09 20 20 20 20 20 20 28 -ids))).. (
77b0: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
77c0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
77d0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
77e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 73 lt-log-port* "s
77f0: 79 6e 63 69 6e 67 20 72 75 6e 73 22 29 20 20 20 yncing runs")
7800: 0a 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
7810: 28 74 61 73 6b 73 3a 73 79 6e 63 2d 72 75 6e 2d (tasks:sync-run-
7820: 64 61 74 61 20 64 62 68 20 63 61 63 68 65 64 2d data dbh cached-
7830: 69 6e 66 6f 20 72 75 6e 2d 69 64 73 20 61 72 65 info run-ids are
7840: 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d a-info smallest-
7850: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
7860: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
7870: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
7880: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
7890: 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 73 79 6e 63 log-port* "sync
78a0: 69 6e 67 20 74 65 73 74 73 22 29 0a 09 09 20 20 ing tests")...
78b0: 20 20 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 (tasks
78c0: 3a 73 79 6e 63 2d 74 65 73 74 73 2d 64 61 74 61 :sync-tests-data
78d0: 20 64 62 68 20 63 61 63 68 65 64 2d 69 6e 66 6f dbh cached-info
78e0: 20 74 65 73 74 2d 69 64 73 20 61 72 65 61 2d 69 test-ids area-i
78f0: 6e 66 6f 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 nfo smallest-las
7900: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 29 0a 20 t-update-time).
7910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7920: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7930: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7940: 70 6f 72 74 2a 20 20 22 73 79 6e 63 69 6e 67 20 port* "syncing
7950: 74 65 73 74 20 73 74 65 70 73 22 29 0a 20 20 20 test steps").
7960: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
7970: 73 6b 73 3a 73 79 6e 63 2d 74 65 73 74 2d 73 74 sks:sync-test-st
7980: 65 70 73 20 64 62 68 20 63 61 63 68 65 64 2d 69 eps dbh cached-i
7990: 6e 66 6f 20 74 65 73 74 2d 73 74 65 70 2d 69 64 nfo test-step-id
79a0: 73 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 2d s smallest-last-
79b0: 75 70 64 61 74 65 2d 74 69 6d 65 29 0a 09 09 09 update-time)....
79c0: 09 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
79d0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
79e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 22 73 79 t-log-port* "sy
79f0: 6e 63 69 6e 67 20 74 65 73 74 20 64 61 74 61 22 ncing test data"
7a00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7a10: 20 20 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 65 (tasks:sync-te
7a20: 73 74 2d 67 65 6e 2d 64 61 74 61 20 64 62 68 20 st-gen-data dbh
7a30: 63 61 63 68 65 64 2d 69 6e 66 6f 20 74 65 73 74 cached-info test
7a40: 2d 64 61 74 61 2d 69 64 73 20 73 6d 61 6c 6c 65 -data-ids smalle
7a50: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
7a60: 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ime).
7a70: 20 20 20 20 20 28 70 72 69 6e 74 20 22 2d 2d 2d (print "---
7a80: 2d 2d 2d 2d 2d 2d 2d 64 6f 6e 65 2d 2d 2d 2d 2d -------done-----
7a90: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 22 29 29 29 0a 20 ----------"))).
7aa0: 20 20 20 20 28 6c 65 74 2a 20 20 28 28 73 6d 61 (let* ((sma
7ab0: 6c 6c 65 73 74 2d 74 69 6d 65 20 28 68 61 73 68 llest-time (hash
7ac0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7ad0: 6c 74 20 73 6d 61 6c 6c 65 73 74 2d 6c 61 73 74 lt smallest-last
7ae0: 2d 75 70 64 61 74 65 2d 74 69 6d 65 20 22 73 6d -update-time "sm
7af0: 61 6c 6c 65 73 74 2d 74 69 6d 65 22 20 23 66 29 allest-time" #f)
7b00: 29 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 )). (debug:p
7b10: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 73 6d 61 rint-info 0 "sma
7b20: 6c 6c 65 73 74 2d 74 69 6d 65 20 3a 22 20 73 6d llest-time :" sm
7b30: 61 6c 6c 65 73 74 2d 74 69 6d 65 20 20 22 20 6c allest-time " l
7b40: 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 22 20 ast-sync-time "
7b50: 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 0a last-sync-time).
7b60: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 6e (if (not (an
7b70: 64 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d d target run-nam
7b80: 65 29 29 20 0a 09 20 20 28 69 66 20 28 6f 72 20 e)) .. (if (or
7b90: 28 61 6e 64 20 73 6d 61 6c 6c 65 73 74 2d 74 69 (and smallest-ti
7ba0: 6d 65 20 28 3e 20 73 6d 61 6c 6c 65 73 74 2d 74 me (> smallest-t
7bb0: 69 6d 65 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 ime last-sync-ti
7bc0: 6d 65 29 29 20 28 61 6e 64 20 73 6d 61 6c 6c 65 me)) (and smalle
7bd0: 73 74 2d 74 69 6d 65 20 28 65 71 3f 20 6c 61 73 st-time (eq? las
7be0: 74 2d 73 79 6e 63 2d 74 69 6d 65 20 30 29 29 29 t-sync-time 0)))
7bf0: 0a 09 09 09 09 28 70 67 64 62 3a 77 72 69 74 65 .....(pgdb:write
7c00: 2d 73 79 6e 63 2d 74 69 6d 65 20 64 62 68 20 61 -sync-time dbh a
7c10: 72 65 61 2d 69 6e 66 6f 20 73 6d 61 6c 6c 65 73 rea-info smalles
7c20: 74 2d 74 69 6d 65 29 29 29 29 29 20 3b 3b 74 68 t-time))))) ;;th
7c30: 69 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 63 is needs to be c
7c40: 68 61 6e 67 65 64 0a 09 28 69 66 20 28 74 61 73 hanged..(if (tas
7c50: 6b 73 3a 73 65 74 2d 61 72 65 61 20 64 62 68 20 ks:set-area dbh
7c60: 63 6f 6e 66 69 67 64 61 74 29 0a 09 20 20 20 20 configdat)..
7c70: 28 74 61 73 6b 73 3a 73 79 6e 63 2d 74 6f 2d 70 (tasks:sync-to-p
7c80: 6f 73 74 67 72 65 73 20 63 6f 6e 66 69 67 64 61 ostgres configda
7c90: 74 20 64 65 73 74 29 0a 09 20 20 20 20 28 62 65 t dest).. (be
7ca0: 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
7cb0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
7cc0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
7cd0: 52 4f 52 3a 20 75 6e 61 62 6c 65 20 74 6f 20 63 ROR: unable to c
7ce0: 72 65 61 74 65 20 61 6e 20 61 72 65 61 20 72 65 reate an area re
7cf0: 63 6f 72 64 22 29 0a 09 20 20 20 20 20 20 23 66 cord").. #f
7d00: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
7d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7d50: 3b 3b 20 4c 20 4f 20 43 20 4b 20 49 20 4e 20 47 ;; L O C K I N G
7d60: 20 20 20 4d 20 45 20 43 20 48 20 41 20 4e 20 49 M E C H A N I
7d70: 20 53 20 4d 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d S M S .;;======
7d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7dc0: 0a 0a 3b 3b 20 66 61 75 78 2d 6c 6f 63 6b 20 69 ..;; faux-lock i
7dd0: 73 20 64 65 70 72 65 63 61 74 65 64 2e 20 50 6c s deprecated. Pl
7de0: 65 61 73 65 20 75 73 65 20 73 69 6d 70 6c 65 2d ease use simple-
7df0: 6c 6f 63 6b 20 62 65 6c 6f 77 0a 3b 3b 0a 28 64 lock below.;;.(d
7e00: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 efine (common:fa
7e10: 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 ux-lock keyname
7e20: 23 21 6b 65 79 20 28 77 61 69 74 2d 74 69 6d 65 #!key (wait-time
7e30: 20 38 29 28 61 6c 6c 6f 77 2d 6c 6f 63 6b 2d 73 8)(allow-lock-s
7e40: 74 65 61 6c 20 23 74 29 29 0a 20 20 28 69 66 20 teal #t)). (if
7e50: 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (rmt:no-sync-get
7e60: 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 /default keyname
7e70: 20 23 66 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 62 #f) ;; do not b
7e80: 65 20 74 65 6d 70 74 65 64 20 74 6f 20 63 6f 6d e tempted to com
7e90: 70 61 72 65 20 74 6f 20 70 69 64 2e 20 6c 6f 63 pare to pid. loc
7ea0: 6b 69 6e 67 20 69 73 20 61 20 6f 6e 65 2d 73 68 king is a one-sh
7eb0: 6f 74 20 61 63 74 69 6f 6e 2c 20 69 66 20 61 6c ot action, if al
7ec0: 72 65 61 64 79 20 6c 6f 63 6b 65 64 20 66 6f 72 ready locked for
7ed0: 20 74 68 69 73 20 70 69 64 20 69 74 20 64 6f 65 this pid it doe
7ee0: 73 6e 27 74 20 61 63 74 75 61 6c 6c 79 20 63 6f sn't actually co
7ef0: 75 6e 74 0a 20 20 20 20 20 20 28 69 66 20 28 3e unt. (if (>
7f00: 20 77 61 69 74 2d 74 69 6d 65 20 30 29 0a 09 20 wait-time 0)..
7f10: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 74 68 (begin.. (th
7f20: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 read-sleep! 1)..
7f30: 20 20 20 20 28 69 66 20 28 65 71 3f 20 77 61 69 (if (eq? wai
7f40: 74 2d 74 69 6d 65 20 31 29 20 3b 3b 20 6f 6e 6c t-time 1) ;; onl
7f50: 79 20 6f 6e 65 20 73 65 63 6f 6e 64 20 6c 65 66 y one second lef
7f60: 74 2c 20 73 74 65 61 6c 20 74 68 65 20 6c 6f 63 t, steal the loc
7f70: 6b 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 k...(begin... (
7f80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7f90: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7fa0: 70 6f 72 74 2a 20 22 73 74 65 61 6c 69 6e 67 20 port* "stealing
7fb0: 6c 6f 63 6b 20 66 6f 72 20 22 20 6b 65 79 6e 61 lock for " keyna
7fc0: 6d 65 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a me)... (common:
7fd0: 66 61 75 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e faux-unlock keyn
7fe0: 61 6d 65 20 66 6f 72 63 65 3a 20 23 74 29 29 29 ame force: #t)))
7ff0: 0a 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 .. (common:fa
8000: 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 ux-lock keyname
8010: 77 61 69 74 2d 74 69 6d 65 3a 20 28 2d 20 77 61 wait-time: (- wa
8020: 69 74 2d 74 69 6d 65 20 31 29 29 29 0a 09 20 20 it-time 1)))..
8030: 23 66 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e #f). (begin
8040: 0a 20 20 20 20 20 20 20 20 28 72 6d 74 3a 6e 6f . (rmt:no
8050: 2d 73 79 6e 63 2d 73 65 74 20 6b 65 79 6e 61 6d -sync-set keynam
8060: 65 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 e (conc (current
8070: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 20 -process-id))).
8080: 20 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 (equal? (
8090: 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 conc (current-pr
80a0: 6f 63 65 73 73 2d 69 64 29 29 20 28 63 6f 6e 63 ocess-id)) (conc
80b0: 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 (rmt:no-sync-ge
80c0: 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d t/default keynam
80d0: 65 20 23 66 29 29 29 29 29 29 0a 0a 28 64 65 66 e #f))))))..(def
80e0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 75 78 ine (common:faux
80f0: 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 -unlock keyname
8100: 23 21 6b 65 79 20 28 66 6f 72 63 65 20 23 66 29 #!key (force #f)
8110: 29 0a 20 20 28 69 66 20 28 6f 72 20 66 6f 72 63 ). (if (or forc
8120: 65 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 63 20 e (equal? (conc
8130: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
8140: 2d 69 64 29 29 20 28 63 6f 6e 63 20 28 72 6d 74 -id)) (conc (rmt
8150: 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 :no-sync-get/def
8160: 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 29 ault keyname #f)
8170: 29 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e ))). (begin
8180: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 72 6d . (if (rm
8190: 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 t:no-sync-get/de
81a0: 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 fault keyname #f
81b0: 29 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 64 ) (rmt:no-sync-d
81c0: 65 6c 21 20 6b 65 79 6e 61 6d 65 29 29 0a 20 20 el! keyname)).
81d0: 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 #t).
81e0: 23 66 29 29 0a 0a 3b 3b 20 73 69 6d 70 6c 65 20 #f))..;; simple
81f0: 6c 6f 63 6b 2e 20 69 6d 70 72 6f 76 65 20 61 6e lock. improve an
8200: 64 20 63 6f 6e 76 65 72 67 65 20 6f 6e 20 74 68 d converge on th
8210: 69 73 20 6f 6e 65 2e 0a 3b 3b 0a 28 64 65 66 69 is one..;;.(defi
8220: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ne (common:simpl
8230: 65 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 29 0a e-lock keyname).
8240: 20 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 (rmt:no-sync-g
8250: 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 29 et-lock keyname)
8260: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
8270: 6f 6e 3a 73 69 6d 70 6c 65 2d 75 6e 6c 6f 63 6b on:simple-unlock
8280: 20 6b 65 79 6e 61 6d 65 20 23 21 6b 65 79 20 28 keyname #!key (
8290: 66 6f 72 63 65 20 23 66 29 29 0a 20 20 28 72 6d force #f)). (rm
82a0: 74 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 6b t:no-sync-del! k
82b0: 65 79 6e 61 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d eyname))..;;====
82c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8300: 3d 3d 0a 3b 3b 20 64 62 20 62 61 73 65 64 20 68 ==.;; db based h
8310: 6f 73 74 20 63 61 6c 6c 73 0a 3b 3b 3d 3d 3d 3d ost calls.;;====
8320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8360: 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ==..;;==========
8370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
83b0: 20 54 20 45 20 53 20 54 20 20 20 4c 20 41 20 55 T E S T L A U
83c0: 20 4e 20 43 20 48 20 49 20 4e 20 47 20 20 20 50 N C H I N G P
83d0: 20 45 20 52 20 20 20 49 20 54 20 45 20 4d 20 20 E R I T E M
83e0: 20 57 20 49 20 54 20 48 20 20 20 48 20 4f 20 53 W I T H H O S
83f0: 20 54 20 20 20 54 20 59 20 50 20 45 20 53 0a 3b T T Y P E S.;
8400: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8440: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b =======.;; .;; [
8450: 68 6f 73 74 73 5d 0a 3b 3b 20 61 72 6d 20 63 75 hosts].;; arm cu
8460: 62 69 65 30 31 20 63 75 62 69 65 30 32 0a 3b 3b bie01 cubie02.;;
8470: 20 78 38 36 5f 36 34 20 7a 65 75 73 20 78 65 6e x86_64 zeus xen
8480: 61 20 6d 79 74 68 30 31 0a 3b 3b 20 61 6c 6c 68 a myth01.;; allh
8490: 6f 73 74 73 20 23 7b 67 20 68 6f 73 74 73 20 61 osts #{g hosts a
84a0: 72 6d 7d 20 23 7b 67 20 68 6f 73 74 73 20 78 38 rm} #{g hosts x8
84b0: 36 5f 36 34 7d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 6_64}.;; .;; [ho
84c0: 73 74 2d 74 79 70 65 73 5d 0a 3b 3b 20 67 65 6e st-types].;; gen
84d0: 65 72 61 6c 20 23 4d 54 4c 4f 57 45 53 54 4c 4f eral #MTLOWESTLO
84e0: 41 44 20 23 7b 67 20 68 6f 73 74 73 20 61 6c 6c AD #{g hosts all
84f0: 68 6f 73 74 73 7d 0a 3b 3b 20 61 72 6d 20 20 20 hosts}.;; arm
8500: 20 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 20 #MTLOWESTLOAD
8510: 23 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 0a 3b #{g hosts arm}.;
8520: 3b 20 6e 62 67 65 6e 65 72 61 6c 20 6e 62 6a 6f ; nbgeneral nbjo
8530: 62 20 72 75 6e 20 4a 4f 42 43 4f 4d 4d 41 4e 44 b run JOBCOMMAND
8540: 20 2d 6c 6f 67 20 24 4d 54 5f 4c 49 4e 4b 54 52 -log $MT_LINKTR
8550: 45 45 2f 24 4d 54 5f 54 41 52 47 45 54 2f 24 4d EE/$MT_TARGET/$M
8560: 54 5f 52 55 4e 4e 41 4d 45 2e 24 4d 54 5f 54 45 T_RUNNAME.$MT_TE
8570: 53 54 4e 41 4d 45 2d 24 4d 54 5f 49 54 45 4d 5f STNAME-$MT_ITEM_
8580: 50 41 54 48 2e 6c 67 6f 0a 3b 3b 0a 3b 3b 20 5b PATH.lgo.;;.;; [
8590: 68 6f 73 74 2d 72 75 6c 65 73 5d 0a 3b 3b 20 23 host-rules].;; #
85a0: 20 6d 61 78 6e 6c 6f 61 64 20 20 20 3d 3e 20 6d maxnload => m
85b0: 61 78 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f ax normalized lo
85c0: 61 64 0a 3b 3b 20 23 20 6d 61 78 6e 6a 6f 62 73 ad.;; # maxnjobs
85d0: 20 20 20 3d 3e 20 6d 61 78 20 6a 6f 62 73 20 70 => max jobs p
85e0: 65 72 20 63 70 75 0a 3b 3b 20 23 20 6d 61 78 6a er cpu.;; # maxj
85f0: 6f 62 72 61 74 65 20 3d 3e 20 6d 61 78 20 6a 6f obrate => max jo
8600: 62 73 20 70 65 72 20 73 65 63 6f 6e 64 0a 3b 3b bs per second.;;
8610: 20 67 65 6e 65 72 61 6c 20 6d 61 78 6e 6c 6f 61 general maxnloa
8620: 64 3d 31 2e 31 3b 20 6d 61 78 6e 6a 6f 62 73 3d d=1.1; maxnjobs=
8630: 31 2e 32 3b 20 6d 61 78 6a 6f 62 72 61 74 65 3d 1.2; maxjobrate=
8640: 30 2e 31 20 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 0.1 .;; .;; [lau
8650: 6e 63 68 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 nchers].;; envse
8660: 74 75 70 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 tup general.;; x
8670: 6f 72 2f 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 or/%/n 4C16G.;;
8680: 25 20 6e 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a % nbgeneral.;; .
8690: 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b ;; [jobtools].;;
86a0: 20 23 20 69 66 20 64 65 66 69 6e 65 64 20 61 6e # if defined an
86b0: 64 20 6e 6f 74 20 22 6e 6f 22 20 66 6c 65 78 69 d not "no" flexi
86c0: 2d 6c 61 75 6e 63 68 65 72 20 77 69 6c 6c 20 62 -launcher will b
86d0: 79 70 61 73 73 20 22 6c 61 75 6e 63 68 65 72 22 ypass "launcher"
86e0: 20 75 6e 6c 65 73 73 20 6e 6f 20 6d 61 74 63 68 unless no match
86f0: 2e 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 75 6e 63 ..;; flexi-launc
8700: 68 65 72 20 79 65 73 20 20 0a 3b 3b 20 6c 61 75 her yes .;; lau
8710: 6e 63 68 65 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a ncher nbfake.;;.
8720: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
8730: 67 65 74 2d 6c 61 75 6e 63 68 65 72 20 63 6f 6e get-launcher con
8740: 66 69 67 64 61 74 20 74 65 73 74 6e 61 6d 65 20 figdat testname
8750: 69 74 65 6d 70 61 74 68 29 0a 20 20 28 6c 65 74 itempath). (let
8760: 20 28 28 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e ((fallback-laun
8770: 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f cher (configf:lo
8780: 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
8790: 6a 6f 62 74 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 jobtools" "launc
87a0: 68 65 72 22 29 29 29 0a 20 20 20 20 28 69 66 20 her"))). (if
87b0: 28 61 6e 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (and (configf:lo
87c0: 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
87d0: 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 jobtools" "flexi
87e0: 2d 6c 61 75 6e 63 68 65 72 22 29 20 3b 3b 20 6f -launcher") ;; o
87f0: 76 65 72 72 69 64 65 73 20 6c 61 75 6e 63 68 65 verrides launche
8800: 72 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 r.. (not (eq
8810: 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ual? (configf:lo
8820: 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
8830: 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 jobtools" "flexi
8840: 2d 6c 61 75 6e 63 68 65 72 22 29 20 22 6e 6f 22 -launcher") "no"
8850: 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 6c 61 75 )))..(let* ((lau
8860: 6e 63 68 65 72 73 20 20 20 20 20 20 20 20 20 28 nchers (
8870: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8880: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 64 61 74 efault configdat
8890: 20 22 6c 61 75 6e 63 68 65 72 73 22 20 27 28 29 "launchers" '()
88a0: 29 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c ))).. (if (null
88b0: 3f 20 6c 61 75 6e 63 68 65 72 73 29 0a 09 20 20 ? launchers)..
88c0: 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 fallback-lau
88d0: 6e 63 68 65 72 0a 09 20 20 20 20 20 20 28 6c 65 ncher.. (le
88e0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
88f0: 72 20 6c 61 75 6e 63 68 65 72 73 29 29 0a 09 09 r launchers))...
8900: 09 20 28 74 61 6c 20 28 63 64 72 20 6c 61 75 6e . (tal (cdr laun
8910: 63 68 65 72 73 29 29 29 0a 09 09 28 6c 65 74 20 chers)))...(let
8920: 28 28 70 61 74 74 20 20 20 20 20 20 28 63 61 72 ((patt (car
8930: 20 68 65 64 29 29 0a 09 09 20 20 20 20 20 20 28 hed))... (
8940: 68 6f 73 74 2d 74 79 70 65 20 28 63 61 64 72 20 host-type (cadr
8950: 68 65 64 29 29 29 0a 09 09 20 20 28 69 66 20 28 hed)))... (if (
8960: 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 74 tests:match patt
8970: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
8980: 74 68 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 th)... (beg
8990: 69 6e 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 in....(debug:pri
89a0: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
89b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 61 lt-log-port* "Ha
89c0: 76 65 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 ve flexi-launche
89d0: 72 20 6d 61 74 63 68 20 66 6f 72 20 22 20 74 65 r match for " te
89e0: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 stname "/" itemp
89f0: 61 74 68 20 22 20 3d 20 22 20 68 6f 73 74 2d 74 ath " = " host-t
8a00: 79 70 65 29 0a 09 09 09 28 6c 65 74 20 28 28 6c ype)....(let ((l
8a10: 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 auncher (configf
8a20: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
8a30: 74 20 22 68 6f 73 74 2d 74 79 70 65 73 22 20 68 t "host-types" h
8a40: 6f 73 74 2d 74 79 70 65 29 29 29 0a 09 09 09 20 ost-type)))....
8a50: 20 28 69 66 20 6c 61 75 6e 63 68 65 72 0a 09 09 (if launcher...
8a60: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c . (let* ((l
8a70: 61 75 6e 63 68 65 72 2d 70 61 72 74 73 20 28 73 auncher-parts (s
8a80: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e tring-split laun
8a90: 63 68 65 72 29 29 0a 09 09 09 09 20 20 20 20 20 cher)).....
8aa0: 28 6c 61 75 6e 63 68 65 72 2d 65 78 65 20 20 20 (launcher-exe
8ab0: 28 63 61 72 20 6c 61 75 6e 63 68 65 72 2d 70 61 (car launcher-pa
8ac0: 72 74 73 29 29 29 0a 09 09 09 09 28 69 66 20 28 rts))).....(if (
8ad0: 65 71 75 61 6c 3f 20 6c 61 75 6e 63 68 65 72 2d equal? launcher-
8ae0: 65 78 65 20 22 23 4d 54 4c 4f 57 45 53 54 4c 4f exe "#MTLOWESTLO
8af0: 41 44 22 29 20 3b 3b 20 74 68 69 73 20 69 73 20 AD") ;; this is
8b00: 6f 75 72 20 73 70 65 63 69 61 6c 20 63 61 73 65 our special case
8b10: 2c 20 77 65 20 77 69 6c 6c 20 66 69 6e 64 20 74 , we will find t
8b20: 68 65 20 6c 6f 77 65 73 74 20 6c 6f 61 64 20 61 he lowest load a
8b30: 6e 64 20 63 72 61 66 74 20 61 20 6e 62 66 61 6b nd craft a nbfak
8b40: 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 e commandline...
8b50: 09 09 20 20 20 20 28 6c 65 74 20 68 6f 73 74 2d .. (let host-
8b60: 6c 6f 6f 70 20 28 28 74 61 72 67 2d 68 6f 73 74 loop ((targ-host
8b70: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 (common:get-lea
8b80: 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 20 28 st-loaded-host (
8b90: 63 64 72 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 cdr launcher-par
8ba0: 74 73 29 20 68 6f 73 74 2d 74 79 70 65 20 63 6f ts) host-type co
8bb0: 6e 66 69 67 64 61 74 29 29 0a 09 09 09 09 09 09 nfigdat)).......
8bc0: 20 20 20 20 28 63 6f 75 6e 74 20 20 20 20 20 31 (count 1
8bd0: 30 30 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 00))..... (
8be0: 69 66 20 74 61 72 67 2d 68 6f 73 74 0a 09 09 09 if targ-host....
8bf0: 09 09 20 20 28 63 6f 6e 63 20 22 72 65 6d 72 75 .. (conc "remru
8c00: 6e 20 22 20 74 61 72 67 2d 68 6f 73 74 29 0a 09 n " targ-host)..
8c10: 09 09 09 09 20 20 28 69 66 20 28 3e 20 63 6f 75 .... (if (> cou
8c20: 6e 74 20 30 29 0a 09 09 09 09 09 20 20 20 20 20 nt 0)......
8c30: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 28 64 (begin.......(d
8c40: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
8c50: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
8c60: 22 49 4e 46 4f 3a 20 57 61 69 74 69 6e 67 20 66 "INFO: Waiting f
8c70: 6f 72 20 61 20 68 6f 73 74 20 66 6f 72 20 68 6f or a host for ho
8c80: 73 74 2d 74 79 70 65 20 22 20 68 6f 73 74 2d 74 st-type " host-t
8c90: 79 70 65 29 0a 09 09 09 09 09 09 28 74 68 72 65 ype).......(thre
8ca0: 61 64 2d 73 6c 65 65 70 21 20 28 2d 20 31 30 31 ad-sleep! (- 101
8cb0: 20 63 6f 75 6e 74 29 29 0a 09 09 09 09 09 09 28 count)).......(
8cc0: 68 6f 73 74 2d 6c 6f 6f 70 20 28 63 6f 6d 6d 6f host-loop (commo
8cd0: 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 n:get-least-load
8ce0: 65 64 2d 68 6f 73 74 20 28 63 64 72 20 6c 61 75 ed-host (cdr lau
8cf0: 6e 63 68 65 72 2d 70 61 72 74 73 29 20 68 6f 73 ncher-parts) hos
8d00: 74 2d 74 79 70 65 20 63 6f 6e 66 69 67 64 61 74 t-type configdat
8d10: 29 0a 09 09 09 09 09 09 09 20 20 20 28 2d 20 63 )........ (- c
8d20: 6f 75 6e 74 20 31 29 29 29 0a 09 09 09 09 09 20 ount 1)))......
8d30: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
8d40: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
8d50: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
8d60: 72 74 2a 20 22 46 41 54 41 4c 3a 20 46 61 69 6c rt* "FATAL: Fail
8d70: 65 64 20 74 6f 20 66 69 6e 64 20 61 20 68 6f 73 ed to find a hos
8d80: 74 20 66 72 6f 6d 20 23 4d 54 4c 4f 57 45 53 54 t from #MTLOWEST
8d90: 4c 4f 41 44 20 66 6f 72 20 68 6f 73 74 2d 74 79 LOAD for host-ty
8da0: 70 65 20 22 20 68 6f 73 74 2d 74 79 70 65 29 0a pe " host-type).
8db0: 09 09 09 09 09 09 28 65 78 69 74 29 29 29 29 29 ......(exit)))))
8dc0: 0a 09 09 09 09 20 20 20 20 6c 61 75 6e 63 68 65 ..... launche
8dd0: 72 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 r)).... (be
8de0: 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 gin.....(debug:p
8df0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
8e00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8e10: 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 6e WARNING: no laun
8e20: 63 68 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 68 cher found for h
8e30: 6f 73 74 2d 74 79 70 65 20 22 20 68 6f 73 74 2d ost-type " host-
8e40: 74 79 70 65 29 0a 09 09 09 09 28 69 66 20 28 6e type).....(if (n
8e50: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 ull? tal).....
8e60: 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 fallback-launc
8e70: 68 65 72 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f her..... (loo
8e80: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
8e90: 74 61 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 tal)))))))...
8ea0: 20 20 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c 20 ;; no match,
8eb0: 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 try again...
8ec0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
8ed0: 29 0a 09 09 09 20 20 66 61 6c 6c 62 61 63 6b 2d ).... fallback-
8ee0: 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 28 6c launcher.... (l
8ef0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
8f00: 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 66 r tal))))))))..f
8f10: 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 allback-launcher
8f20: 29 29 29 0a 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 )))..;; ideally
8f30: 70 75 74 20 61 6c 6c 20 74 68 69 73 20 69 6e 66 put all this inf
8f40: 6f 20 69 6e 74 6f 20 74 68 65 20 64 62 2c 20 6e o into the db, n
8f50: 6f 20 6e 65 65 64 20 74 6f 20 70 72 65 73 65 72 o need to preser
8f60: 76 65 20 69 74 20 61 63 72 6f 73 73 20 6d 6f 76 ve it across mov
8f70: 69 6e 67 20 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a ing homehost.;;.
8f80: 3b 3b 20 72 65 74 75 72 6e 20 6c 69 73 74 20 6f ;; return list o
8f90: 66 0a 3b 3b 20 20 28 20 72 65 61 63 68 61 62 6c f.;; ( reachabl
8fa0: 65 3f 20 63 70 75 6c 6f 61 64 20 75 70 64 61 74 e? cpuload updat
8fb0: 65 2d 74 69 6d 65 20 29 0a 28 64 65 66 69 6e 65 e-time ).(define
8fc0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 (common:get-hos
8fd0: 74 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 t-info hostname)
8fe0: 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 69 . (let* ((loadi
8ff0: 6e 66 6f 20 20 20 20 20 20 20 20 20 20 20 20 20 nfo
9000: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 (rmt
9010: 3a 67 65 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 :get-latest-host
9020: 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 6d 65 29 29 -load hostname))
9030: 20 3b 3b 20 69 66 20 74 68 69 73 20 68 6f 73 74 ;; if this host
9040: 20 68 61 70 70 65 6e 73 20 74 6f 20 68 61 76 65 happens to have
9050: 20 62 65 65 6e 20 72 65 63 65 6e 74 6c 79 20 75 been recently u
9060: 73 65 64 20 62 79 20 61 20 74 65 73 74 20 72 65 sed by a test re
9070: 75 73 65 20 74 68 65 20 6c 6f 61 64 20 64 61 74 use the load dat
9080: 61 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 a. (load
9090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
90b0: 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 20 20 r loadinfo)).
90c0: 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 6d 70 (load-samp
90d0: 6c 65 2d 74 69 6d 65 20 20 20 20 20 20 20 20 20 le-time
90e0: 20 20 20 20 20 20 20 20 28 63 64 72 20 6c 6f 61 (cdr loa
90f0: 64 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 dinfo)).
9100: 20 28 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 61 67 (load-sample-ag
9110: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
9120: 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (- (current-s
9130: 65 63 6f 6e 64 73 29 20 6c 6f 61 64 2d 73 61 6d econds) load-sam
9140: 70 6c 65 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 ple-time)).
9150: 20 20 20 20 28 6c 6f 61 64 69 6e 66 6f 2d 74 69 (loadinfo-ti
9160: 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 73 20 20 20 meout-seconds
9170: 20 20 20 20 20 20 36 29 20 3b 3b 20 74 68 69 73 6) ;; this
9180: 20 77 61 73 20 32 30 20 73 65 63 6f 6e 64 73 2c was 20 seconds,
9190: 20 73 65 65 6d 73 20 77 61 79 20 74 6f 6f 20 6c seems way too l
91a0: 61 78 2e 20 53 77 69 74 63 68 20 74 6f 20 36 20 ax. Switch to 6
91b0: 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 20 20 seconds.
91c0: 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 (host-last-upda
91d0: 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e te-timeout-secon
91e0: 64 73 20 34 29 0a 20 20 20 20 20 20 20 20 20 28 ds 4). (
91f0: 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 2d 74 host-rec (hash-t
9200: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
9210: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f *host-loads* ho
9220: 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 stname #f)).
9230: 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f 6e 64 ). (cond
9240: 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 2d 73 . ((< load-s
9250: 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 69 6e ample-age loadin
9260: 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e fo-timeout-secon
9270: 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 ds). (list
9280: 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c #t. l
9290: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 0a oad-sample-time.
92a0: 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 64 load
92b0: 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 68 6f )). ((and ho
92c0: 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 20 20 st-rec.
92d0: 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 (< (current-se
92e0: 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 74 2d conds) (+ (host-
92f0: 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 74 last-update host
9300: 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 74 2d -rec) host-last-
9310: 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 update-timeout-s
9320: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
9330: 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 20 (list #t.
9340: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
9350: 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 29 update host-rec)
9360: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f . (ho
9370: 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 st-last-cpuload
9380: 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 20 20 host-rec ))).
9390: 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d ((common:unix-
93a0: 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a 20 ping hostname).
93b0: 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 20 (list #t.
93c0: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
93d0: 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 nt-seconds).
93e0: 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 (alist-r
93f0: 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 ef 'adj-core-loa
9400: 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f d (common:get-no
9410: 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 rmalized-cpu-loa
9420: 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 3b d hostname)))) ;
9430: 3b 20 74 68 69 73 20 69 73 20 63 68 65 61 70 65 ; this is cheape
9440: 72 20 74 68 61 6e 20 79 6f 75 20 6d 69 67 68 74 r than you might
9450: 20 74 68 69 6e 6b 2e 20 67 65 74 2d 6e 6f 72 6d think. get-norm
9460: 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 alized-cpu-load
9470: 69 73 20 63 61 63 68 65 64 20 66 6f 72 20 75 70 is cached for up
9480: 20 74 6f 20 35 20 73 65 63 6f 6e 64 73 0a 20 20 to 5 seconds.
9490: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 (else. (
94a0: 6c 69 73 74 20 23 66 20 30 20 2d 31 29 20 3b 3b list #f 0 -1) ;;
94b0: 20 62 61 64 20 68 6f 73 74 2c 20 64 6f 6e 27 74 bad host, don't
94c0: 20 75 73 65 21 0a 20 20 20 20 20 20 29 29 29 29 use!. ))))
94d0: 0a 0a 3b 3b 20 73 65 65 20 64 65 66 73 74 72 75 ..;; see defstru
94e0: 63 74 20 68 6f 73 74 20 61 74 20 74 6f 70 20 6f ct host at top o
94f0: 66 20 66 69 6c 65 2e 0a 3b 3b 20 20 20 20 68 6f f file..;; ho
9500: 73 74 3a 20 72 65 61 63 68 61 62 6c 65 20 6c 61 st: reachable la
9510: 73 74 2d 75 70 64 61 74 65 20 6c 61 73 74 2d 75 st-update last-u
9520: 73 65 64 20 6c 61 73 74 2d 63 70 75 6c 6f 61 64 sed last-cpuload
9530: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
9540: 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 2d mon:update-host-
9550: 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 74 loads-table host
9560: 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 28 s-raw). (let* (
9570: 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 28 (hosts (filter (
9580: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
9590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95a0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
95b0: 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 53 ch (regexp "^\\S
95c0: 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 20 +$") x)).
95d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
95e0: 20 68 6f 73 74 73 2d 72 61 77 29 29 29 0a 20 20 hosts-raw))).
95f0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
9600: 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 74 6e 61 (lambda (hostna
9610: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
9620: 20 28 28 72 65 63 20 20 20 20 20 20 20 28 6c 65 ((rec (le
9630: 74 20 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c t ((h (hash-tabl
9640: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 e-ref/default *h
9650: 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e ost-loads* hostn
9660: 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 ame #f))).
9670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9680: 20 20 20 20 28 69 66 20 68 0a 20 20 20 20 20 20 (if h.
9690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96a0: 20 20 20 20 20 20 20 20 68 0a 20 20 20 20 20 20 h.
96b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96c0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 (let ((h
96d0: 20 28 6d 61 6b 65 2d 68 6f 73 74 29 29 29 0a 20 (make-host))).
96e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9700: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
9710: 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 *host-loads* hos
9720: 74 6e 61 6d 65 20 68 29 0a 20 20 20 20 20 20 20 tname h).
9730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9740: 20 20 20 20 20 20 20 20 20 68 29 29 29 29 0a 20 h)))).
9750: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f (ho
9760: 73 74 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 st-info
9770: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 (common:get-host
9780: 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 -info hostname))
9790: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
97a0: 69 73 2d 72 65 61 63 68 61 62 6c 65 20 20 20 20 is-reachable
97b0: 20 20 28 63 61 72 20 68 6f 73 74 2d 69 6e 66 6f (car host-info
97c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
97d0: 20 28 6c 61 73 74 2d 72 65 61 63 68 65 64 2d 74 (last-reached-t
97e0: 69 6d 65 20 28 63 61 64 72 20 68 6f 73 74 2d 69 ime (cadr host-i
97f0: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 nfo)).
9800: 20 20 20 20 28 6c 6f 61 64 20 20 20 20 20 20 20 (load
9810: 20 20 20 20 20 20 20 28 63 61 64 64 72 20 68 6f (caddr ho
9820: 73 74 2d 69 6e 66 6f 29 29 29 0a 20 20 20 20 20 st-info))).
9830: 20 20 20 20 28 68 6f 73 74 2d 72 65 61 63 68 61 (host-reacha
9840: 62 6c 65 2d 73 65 74 21 20 20 20 20 72 65 63 20 ble-set! rec
9850: 69 73 2d 72 65 61 63 68 61 62 6c 65 29 0a 20 20 is-reachable).
9860: 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 (host-las
9870: 74 2d 75 70 64 61 74 65 2d 73 65 74 21 20 20 72 t-update-set! r
9880: 65 63 20 6c 61 73 74 2d 72 65 61 63 68 65 64 2d ec last-reached-
9890: 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 28 time). (
98a0: 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 host-last-cpuloa
98b0: 64 2d 73 65 74 21 20 72 65 63 20 6c 6f 61 64 29 d-set! rec load)
98c0: 29 29 0a 20 20 20 20 20 68 6f 73 74 73 29 29 29 )). hosts)))
98d0: 0a 0a 3b 3b 20 67 6f 20 74 68 72 6f 75 67 68 20 ..;; go through
98e0: 74 68 65 20 68 6f 73 74 73 20 66 72 6f 6d 20 6c the hosts from l
98f0: 65 61 73 74 20 72 65 63 65 6e 74 6c 79 20 75 73 east recently us
9900: 65 64 20 74 6f 20 6d 6f 73 74 20 72 65 63 65 6e ed to most recen
9910: 74 6c 79 20 75 73 65 64 2c 20 70 69 63 6b 20 74 tly used, pick t
9920: 68 65 20 66 69 72 73 74 20 74 68 61 74 20 6d 65 he first that me
9930: 65 74 73 20 74 68 65 20 6c 6f 61 64 20 63 72 69 ets the load cri
9940: 74 65 72 61 6c 20 66 72 6f 6d 20 74 68 65 0a 3b teral from the.;
9950: 3b 20 5b 68 6f 73 74 2d 72 75 6c 65 73 5d 20 73 ; [host-rules] s
9960: 65 63 74 69 6f 6e 2e 0a 3b 3b 0a 28 64 65 66 69 ection..;;.(defi
9970: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ne (common:get-l
9980: 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 east-loaded-host
9990: 20 68 6f 73 74 73 2d 72 61 77 20 68 6f 73 74 2d hosts-raw host-
99a0: 74 79 70 65 20 63 6f 6e 66 69 67 64 61 74 29 0a type configdat).
99b0: 20 20 28 6c 65 74 2a 20 28 28 72 64 61 74 20 20 (let* ((rdat
99c0: 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (configf:lo
99d0: 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
99e0: 68 6f 73 74 2d 72 75 6c 65 73 22 20 68 6f 73 74 host-rules" host
99f0: 2d 74 79 70 65 29 29 0a 09 20 28 72 75 6c 65 73 -type)).. (rules
9a00: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 61 (common:va
9a10: 6c 2d 3e 61 6c 69 73 74 20 28 6f 72 20 72 64 61 l->alist (or rda
9a20: 74 20 22 22 29 20 63 6f 6e 76 65 72 74 3a 20 23 t "") convert: #
9a30: 74 29 29 20 20 20 3b 3b 20 6d 61 78 6e 6c 6f 61 t)) ;; maxnloa
9a40: 64 2c 20 6d 61 78 6e 6a 6f 62 73 2c 20 6d 61 78 d, maxnjobs, max
9a50: 6a 6f 62 72 61 74 65 0a 09 20 28 6d 61 78 6e 6c jobrate.. (maxnl
9a60: 6f 61 64 20 20 20 28 63 6f 6d 6d 6f 6e 3a 61 6c oad (common:al
9a70: 69 73 74 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ist-ref/default
9a80: 27 6d 61 78 6e 6c 6f 61 64 20 72 75 6c 65 73 20 'maxnload rules
9a90: 31 2e 35 29 29 20 3b 3b 20 6d 61 78 20 6e 6f 72 1.5)) ;; max nor
9aa0: 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 0a 09 20 28 malized load.. (
9ab0: 6d 61 78 6e 6a 6f 62 73 20 20 20 28 63 6f 6d 6d maxnjobs (comm
9ac0: 6f 6e 3a 61 6c 69 73 74 2d 72 65 66 2f 64 65 66 on:alist-ref/def
9ad0: 61 75 6c 74 20 27 6d 61 78 6e 6a 6f 62 73 20 72 ault 'maxnjobs r
9ae0: 75 6c 65 73 20 31 2e 35 29 29 20 3b 3b 20 6d 61 ules 1.5)) ;; ma
9af0: 78 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6e 75 6d x normalized num
9b00: 62 65 72 20 6f 66 20 6a 6f 62 73 0a 09 20 28 6d ber of jobs.. (m
9b10: 61 78 6a 6f 62 72 61 74 65 20 28 63 6f 6d 6d 6f axjobrate (commo
9b20: 6e 3a 61 6c 69 73 74 2d 72 65 66 2f 64 65 66 61 n:alist-ref/defa
9b30: 75 6c 74 20 27 6d 61 78 6a 6f 62 72 61 74 65 20 ult 'maxjobrate
9b40: 72 75 6c 65 73 20 28 2f 20 31 20 36 29 29 29 20 rules (/ 1 6)))
9b50: 3b 3b 20 6d 61 78 20 72 61 74 65 20 6f 66 20 73 ;; max rate of s
9b60: 75 62 6d 69 74 74 69 6e 67 20 6a 6f 62 73 20 74 ubmitting jobs t
9b70: 6f 20 61 20 67 69 76 65 6e 20 68 6f 73 74 20 69 o a given host i
9b80: 6e 20 6a 6f 62 73 2f 73 65 63 6f 6e 64 0a 09 20 n jobs/second..
9b90: 28 68 6f 73 74 73 20 20 20 20 20 20 28 66 69 6c (hosts (fil
9ba0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
9bb0: 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
9bc0: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
9bd0: 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 09 09 "^\\S+$") x))...
9be0: 09 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 . hosts-raw)
9bf0: 29 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 28 62 ). ;; (b
9c00: 65 73 74 2d 68 6f 73 74 20 23 66 29 0a 09 20 28 est-host #f).. (
9c10: 67 65 74 2d 72 65 63 20 20 20 20 28 6c 61 6d 62 get-rec (lamb
9c20: 64 61 20 28 68 6f 73 74 6e 61 6d 65 29 0a 09 09 da (hostname)...
9c30: 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; (print
9c40: 20 22 67 65 74 2d 72 65 63 20 68 6f 73 74 6e 61 "get-rec hostna
9c50: 6d 65 3d 22 20 68 6f 73 74 6e 61 6d 65 29 0a 09 me=" hostname)..
9c60: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 . (let ((h
9c70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
9c80: 2f 64 65 66 61 75 6c 74 20 2a 68 6f 73 74 2d 6c /default *host-l
9c90: 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 23 oads* hostname #
9ca0: 66 29 29 29 0a 09 09 09 20 28 69 66 20 68 0a 09 f))).... (if h..
9cb0: 09 09 20 20 20 20 20 68 0a 09 09 09 20 20 20 20 .. h....
9cc0: 20 28 6c 65 74 20 28 28 68 20 28 6d 61 6b 65 2d (let ((h (make-
9cd0: 68 6f 73 74 29 29 29 0a 09 09 09 20 20 20 20 20 host)))....
9ce0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
9cf0: 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 t! *host-loads*
9d00: 68 6f 73 74 6e 61 6d 65 20 68 29 0a 09 09 09 20 hostname h)....
9d10: 20 20 20 20 20 20 68 29 29 29 29 29 0a 20 20 20 h))))).
9d20: 20 20 20 20 20 20 28 62 65 73 74 2d 6c 6f 61 64 (best-load
9d30: 20 39 39 39 39 39 29 0a 20 20 20 20 20 20 20 20 99999).
9d40: 20 28 63 75 72 72 2d 74 69 6d 65 20 28 63 75 72 (curr-time (cur
9d50: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
9d60: 20 28 67 65 74 2d 68 6f 73 74 73 2d 73 6f 72 74 (get-hosts-sort
9d70: 65 64 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 74 ed (lambda (host
9d80: 73 29 0a 09 09 09 20 20 20 20 20 28 73 6f 72 74 s).... (sort
9d90: 20 68 6f 73 74 73 20 28 6c 61 6d 62 64 61 20 28 hosts (lambda (
9da0: 61 20 62 29 0a 09 09 09 09 09 20 20 20 28 6c 65 a b)...... (le
9db0: 74 20 28 28 61 2d 72 65 63 20 28 67 65 74 2d 72 t ((a-rec (get-r
9dc0: 65 63 20 61 29 29 0a 09 09 09 09 09 09 20 28 62 ec a))....... (b
9dd0: 2d 72 65 63 20 28 67 65 74 2d 72 65 63 20 62 29 -rec (get-rec b)
9de0: 29 29 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 20 ))...... ;;
9df0: 28 70 72 69 6e 74 20 22 61 3d 22 20 61 20 22 20 (print "a=" a "
9e00: 61 2d 72 65 63 3d 22 20 61 2d 72 65 63 20 22 20 a-rec=" a-rec "
9e10: 68 6f 73 74 2d 6c 61 73 74 2d 75 73 65 64 3d 22 host-last-used="
9e20: 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 73 65 64 (host-last-used
9e30: 20 61 2d 72 65 63 29 29 0a 09 09 09 09 09 20 20 a-rec))......
9e40: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 62 3d ;; (print "b=
9e50: 22 20 62 20 22 20 62 2d 72 65 63 3d 22 20 62 2d " b " b-rec=" b-
9e60: 72 65 63 20 22 20 68 6f 73 74 2d 6c 61 73 74 2d rec " host-last-
9e70: 75 73 65 64 3d 22 20 28 68 6f 73 74 2d 6c 61 73 used=" (host-las
9e80: 74 2d 75 73 65 64 20 62 2d 72 65 63 29 29 0a 09 t-used b-rec))..
9e90: 09 09 09 09 20 20 20 20 20 28 3c 20 28 68 6f 73 .... (< (hos
9ea0: 74 2d 6c 61 73 74 2d 75 73 65 64 20 61 2d 72 65 t-last-used a-re
9eb0: 63 29 0a 09 09 09 09 09 09 28 68 6f 73 74 2d 6c c).......(host-l
9ec0: 61 73 74 2d 75 73 65 64 20 62 2d 72 65 63 29 29 ast-used b-rec))
9ed0: 29 29 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 )))))). (debu
9ee0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
9ef0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
9f00: 46 4f 3a 20 68 6f 73 74 73 2d 73 6f 72 74 65 64 FO: hosts-sorted
9f10: 3d 22 20 28 67 65 74 2d 68 6f 73 74 73 2d 73 6f =" (get-hosts-so
9f20: 72 74 65 64 20 68 6f 73 74 73 29 29 0a 20 20 20 rted hosts)).
9f30: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 68 6f 73 74 (if (null? host
9f40: 73 29 0a 09 23 66 20 3b 3b 20 6e 6f 20 68 6f 73 s)..#f ;; no hos
9f50: 74 73 20 74 6f 20 73 65 6c 65 63 74 20 66 72 6f ts to select fro
9f60: 6d 2e 20 41 6c 6c 20 64 6f 6e 65 20 61 6e 64 20 m. All done and
9f70: 67 69 76 69 6e 67 20 75 70 20 6e 6f 77 2e 0a 09 giving up now...
9f80: 28 6c 65 74 20 28 28 68 6f 73 74 73 2d 73 6f 72 (let ((hosts-sor
9f90: 74 65 64 20 28 67 65 74 2d 68 6f 73 74 73 2d 73 ted (get-hosts-s
9fa0: 6f 72 74 65 64 20 68 6f 73 74 73 29 29 29 0a 09 orted hosts)))..
9fb0: 20 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 (common:update
9fc0: 2d 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c -host-loads-tabl
9fd0: 65 20 68 6f 73 74 73 29 0a 09 20 20 28 6c 65 74 e hosts).. (let
9fe0: 20 6c 6f 6f 70 20 28 28 68 6f 73 74 6e 61 6d 65 loop ((hostname
9ff0: 20 20 28 63 61 72 20 68 6f 73 74 73 2d 73 6f 72 (car hosts-sor
a000: 74 65 64 29 29 0a 09 09 20 20 20 20 20 28 74 61 ted))... (ta
a010: 6c 20 20 20 20 20 20 20 28 63 64 72 20 68 6f 73 l (cdr hos
a020: 74 73 2d 73 6f 72 74 65 64 29 29 0a 09 09 20 20 ts-sorted))...
a030: 20 20 20 28 62 65 73 74 2d 68 6f 73 74 20 23 66 (best-host #f
a040: 29 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 )).. (let* ((
a050: 72 65 63 20 20 20 20 20 20 20 28 67 65 74 2d 72 rec (get-r
a060: 65 63 20 68 6f 73 74 6e 61 6d 65 29 29 0a 09 09 ec hostname))...
a070: 20 20 20 28 72 65 61 63 68 61 62 6c 65 20 28 68 (reachable (h
a080: 6f 73 74 2d 72 65 61 63 68 61 62 6c 65 20 20 20 ost-reachable
a090: 20 20 72 65 63 29 29 0a 09 09 20 20 20 28 6c 6f rec))... (lo
a0a0: 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 ad (host-la
a0b0: 73 74 2d 63 70 75 6c 6f 61 64 20 20 72 65 63 29 st-cpuload rec)
a0c0: 29 0a 09 09 20 20 20 28 6c 61 73 74 2d 75 73 65 )... (last-use
a0d0: 64 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 73 65 d (host-last-use
a0e0: 64 20 20 20 20 20 72 65 63 29 29 0a 09 09 20 20 d rec))...
a0f0: 20 28 64 65 6c 74 61 20 20 20 20 20 28 2d 20 63 (delta (- c
a100: 75 72 72 2d 74 69 6d 65 20 6c 61 73 74 2d 75 73 urr-time last-us
a110: 65 64 29 29 0a 09 09 20 20 20 28 6a 6f 62 2d 72 ed))... (job-r
a120: 61 74 65 20 20 28 69 66 20 28 3e 20 64 65 6c 74 ate (if (> delt
a130: 61 20 30 29 0a 09 09 09 09 20 20 28 2f 20 31 20 a 0)..... (/ 1
a140: 64 65 6c 74 61 29 0a 09 09 09 09 20 20 39 39 39 delta)..... 999
a150: 29 29 20 3b 3b 20 6a 6f 62 73 20 70 65 72 20 73 )) ;; jobs per s
a160: 65 63 6f 6e 64 0a 09 09 20 20 20 28 6e 65 77 2d econd... (new-
a170: 62 65 73 74 20 20 0a 09 09 20 20 20 20 28 63 6f best ... (co
a180: 6e 64 0a 09 09 20 20 20 20 20 28 28 6e 6f 74 20 nd... ((not
a190: 72 65 61 63 68 61 62 6c 65 29 0a 09 09 20 20 20 reachable)...
a1a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
a1b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
a1c0: 6f 72 74 2a 20 22 53 6b 69 70 70 69 6e 67 20 68 ort* "Skipping h
a1d0: 6f 73 74 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 ost " hostname "
a1e0: 20 61 73 20 69 74 20 63 61 6e 6e 6f 74 20 62 65 as it cannot be
a1f0: 20 72 65 61 63 68 65 64 2e 22 29 0a 09 09 20 20 reached.")...
a200: 20 20 20 20 62 65 73 74 2d 68 6f 73 74 29 0a 09 best-host)..
a210: 09 20 20 20 20 20 28 28 61 6e 64 20 28 3c 20 6c . ((and (< l
a220: 6f 61 64 20 6d 61 78 6e 6c 6f 61 64 29 20 20 20 oad maxnload)
a230: 20 20 20 20 20 3b 3b 20 6c 6f 61 64 20 69 73 20 ;; load is
a240: 61 63 63 65 70 74 61 62 6c 65 0a 09 09 09 20 20 acceptable....
a250: 20 28 3c 20 6a 6f 62 2d 72 61 74 65 20 6d 61 78 (< job-rate max
a260: 6a 6f 62 72 61 74 65 29 29 20 3b 3b 20 6a 6f 62 jobrate)) ;; job
a270: 20 72 61 74 65 20 69 73 20 61 63 63 65 70 74 61 rate is accepta
a280: 62 6c 65 0a 09 09 20 20 20 20 20 20 28 73 65 74 ble... (set
a290: 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f 61 64 ! best-load load
a2a0: 29 0a 09 09 20 20 20 20 20 20 68 6f 73 74 6e 61 )... hostna
a2b0: 6d 65 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 me)... (else
a2c0: 20 62 65 73 74 2d 68 6f 73 74 29 29 29 29 0a 09 best-host))))..
a2d0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
a2e0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
a2f0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 54 g-port* "INFO: T
a300: 72 79 69 6e 67 20 68 6f 73 74 20 22 20 68 6f 73 rying host " hos
a310: 74 6e 61 6d 65 20 22 20 77 69 74 68 20 6c 6f 61 tname " with loa
a320: 64 20 22 20 6c 6f 61 64 20 22 2c 20 6c 61 73 74 d " load ", last
a330: 20 75 73 65 64 20 22 20 64 65 6c 74 61 20 22 20 used " delta "
a340: 73 65 63 6f 6e 64 73 20 61 67 6f 2c 20 77 69 74 seconds ago, wit
a350: 68 20 6a 6f 62 2d 72 61 74 65 20 22 20 6a 6f 62 h job-rate " job
a360: 2d 72 61 74 65 20 22 20 66 6f 72 20 72 75 6e 6e -rate " for runn
a370: 69 6e 67 20 61 20 74 65 73 74 2e 22 20 29 0a 09 ing a test." )..
a380: 20 20 20 20 20 20 28 69 66 20 6e 65 77 2d 62 65 (if new-be
a390: 73 74 0a 09 09 20 20 28 62 65 67 69 6e 20 3b 3b st... (begin ;;
a3a0: 20 66 6f 75 6e 64 20 61 20 68 6f 73 74 2c 20 72 found a host, r
a3b0: 65 74 75 72 6e 20 69 74 0a 09 09 20 20 20 20 28 eturn it... (
a3c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
a3d0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
a3e0: 20 22 49 4e 46 4f 3a 20 46 6f 75 6e 64 20 68 6f "INFO: Found ho
a3f0: 73 74 3a 20 22 20 6e 65 77 2d 62 65 73 74 20 22 st: " new-best "
a400: 20 6c 6f 61 64 3a 20 22 20 6c 6f 61 64 20 22 20 load: " load "
a410: 6c 61 73 74 2d 75 73 65 64 3a 20 22 20 64 65 6c last-used: " del
a420: 74 61 20 22 20 73 65 63 6f 6e 64 73 20 61 67 6f ta " seconds ago
a430: 2c 20 77 69 74 68 20 6a 6f 62 2d 72 61 74 65 3a , with job-rate:
a440: 20 22 20 6a 6f 62 2d 72 61 74 65 29 0a 09 09 20 " job-rate)...
a450: 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 73 (host-last-us
a460: 65 64 2d 73 65 74 21 20 72 65 63 20 63 75 72 72 ed-set! rec curr
a470: 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 6e 65 77 -time)... new
a480: 2d 62 65 73 74 29 0a 09 09 20 20 28 69 66 20 28 -best)... (if (
a490: 6e 75 6c 6c 3f 20 74 61 6c 29 20 23 66 20 28 6c null? tal) #f (l
a4a0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
a4b0: 72 20 74 61 6c 29 20 62 65 73 74 2d 68 6f 73 74 r tal) best-host
a4c0: 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 )))))))))..(defi
a4d0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d ne (common:wait-
a4e0: 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c for-cpuload maxl
a4f0: 6f 61 64 2d 69 6e 20 6e 75 6d 63 70 75 73 2d 69 oad-in numcpus-i
a500: 6e 20 77 61 69 74 64 65 6c 61 79 20 23 21 6b 65 n waitdelay #!ke
a510: 79 20 28 63 6f 75 6e 74 20 31 30 30 30 29 20 28 y (count 1000) (
a520: 6d 73 67 20 23 66 29 28 72 65 6d 6f 74 65 2d 68 msg #f)(remote-h
a530: 6f 73 74 20 23 66 29 28 66 6f 72 63 65 2d 6d 61 ost #f)(force-ma
a540: 78 6c 6f 61 64 20 23 66 29 29 0a 20 20 28 6c 65 xload #f)). (le
a550: 74 2a 20 28 28 6c 6f 61 64 61 76 67 20 28 63 6f t* ((loadavg (co
a560: 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 mmon:get-cpu-loa
a570: 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 0a d remote-host)).
a580: 09 20 28 6e 75 6d 63 70 75 73 20 28 69 66 20 28 . (numcpus (if (
a590: 3c 3d 20 31 20 6e 75 6d 63 70 75 73 2d 69 6e 29 <= 1 numcpus-in)
a5a0: 20 3b 3b 20 6e 6f 74 20 70 6f 73 73 69 62 6c 65 ;; not possible
a5b0: 20 74 6f 20 68 61 76 65 20 7a 65 72 6f 2e 20 20 to have zero.
a5c0: 49 66 20 77 65 20 67 65 74 20 31 2c 20 69 74 27 If we get 1, it'
a5d0: 73 20 70 6f 73 73 69 62 6c 65 20 74 68 61 74 20 s possible that
a5e0: 77 65 20 67 6f 74 20 74 68 65 20 70 72 65 76 69 we got the previ
a5f0: 6f 75 73 20 64 65 66 61 75 6c 74 2c 20 61 6e 64 ous default, and
a600: 20 77 65 20 73 68 6f 75 6c 64 20 63 68 65 63 6b we should check
a610: 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 20 28 again... (
a620: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 common:get-num-c
a630: 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 pus remote-host)
a640: 0a 09 09 20 20 20 20 20 20 6e 75 6d 63 70 75 73 ... numcpus
a650: 2d 69 6e 29 29 0a 09 20 28 6d 61 78 6c 6f 61 64 -in)).. (maxload
a660: 20 28 69 66 20 66 6f 72 63 65 2d 6d 61 78 6c 6f (if force-maxlo
a670: 61 64 0a 09 09 20 20 20 20 20 20 6d 61 78 6c 6f ad... maxlo
a680: 61 64 2d 69 6e 0a 09 09 20 20 20 20 20 20 28 6d ad-in... (m
a690: 61 78 20 6d 61 78 6c 6f 61 64 2d 69 6e 20 30 2e ax maxload-in 0.
a6a0: 35 29 29 29 20 3b 3b 20 73 6f 20 6d 61 78 6c 6f 5))) ;; so maxlo
a6b0: 61 64 20 6d 75 73 74 20 62 65 20 67 72 65 61 74 ad must be great
a6c0: 65 72 20 74 68 61 6e 20 30 2e 35 20 66 6f 72 20 er than 0.5 for
a6d0: 6e 6f 77 20 42 55 47 20 2d 20 46 49 58 4d 45 3f now BUG - FIXME?
a6e0: 0a 09 20 28 66 69 72 73 74 20 20 20 28 63 61 72 .. (first (car
a6f0: 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 6e 65 loadavg)).. (ne
a700: 78 74 20 20 20 20 28 63 61 64 72 20 6c 6f 61 64 xt (cadr load
a710: 61 76 67 29 29 0a 09 20 28 61 64 6a 6c 6f 61 64 avg)).. (adjload
a720: 20 28 2a 20 6d 61 78 6c 6f 61 64 20 28 6d 61 78 (* maxload (max
a730: 20 31 20 6e 75 6d 63 70 75 73 29 29 29 20 3b 3b 1 numcpus))) ;;
a740: 20 70 6f 73 73 69 62 6c 65 20 62 75 67 20 77 68 possible bug wh
a750: 65 72 65 20 6e 75 6d 63 70 75 73 20 28 6f 72 20 ere numcpus (or
a760: 63 6f 75 6c 64 20 62 65 20 6d 61 78 6c 6f 61 64 could be maxload
a770: 29 20 69 73 20 7a 65 72 6f 2c 20 63 72 75 64 65 ) is zero, crude
a780: 20 66 61 6c 6c 62 61 63 6b 20 69 73 20 74 6f 20 fallback is to
a790: 61 74 20 6c 65 61 73 74 20 75 73 65 20 31 0a 09 at least use 1..
a7a0: 20 28 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 (loadjmp (- fir
a7b0: 73 74 20 6e 65 78 74 29 29 0a 20 20 20 20 20 20 st next)).
a7c0: 20 20 20 28 61 64 6a 77 61 69 74 20 28 6d 69 6e (adjwait (min
a7d0: 20 28 2b 20 33 30 30 20 28 72 61 6e 64 6f 6d 20 (+ 300 (random
a7e0: 31 30 29 29 20 28 61 62 73 20 28 2a 20 28 2b 20 10)) (abs (* (+
a7f0: 28 72 61 6e 64 6f 6d 20 31 30 29 28 2f 20 28 2d (random 10)(/ (-
a800: 20 31 30 30 30 20 63 6f 75 6e 74 29 20 31 30 29 1000 count) 10)
a810: 20 77 61 69 74 64 65 6c 61 79 29 20 28 2d 20 66 waitdelay) (- f
a820: 69 72 73 74 20 61 64 6a 6c 6f 61 64 29 20 29 29 irst adjload) ))
a830: 20 20 29 29 29 20 3b 3b 20 61 64 64 20 73 6f 6d ))) ;; add som
a840: 65 20 72 61 6e 64 6f 6d 6e 65 73 73 20 74 6f 20 e randomness to
a850: 74 68 65 20 74 69 6d 65 20 74 6f 20 62 72 65 61 the time to brea
a860: 6b 20 61 6e 79 20 61 6c 69 67 6e 6d 65 6e 74 20 k any alignment
a870: 77 68 65 72 65 20 6e 65 74 62 61 74 63 68 20 64 where netbatch d
a880: 75 6d 70 73 20 6d 61 6e 79 20 6a 6f 62 73 20 74 umps many jobs t
a890: 6f 20 6d 61 63 68 69 6e 65 73 20 73 69 6d 75 6c o machines simul
a8a0: 74 61 6e 65 6f 75 73 6c 79 0a 20 20 20 20 28 64 taneously. (d
a8b0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
a8c0: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
a8d0: 6f 72 74 2a 20 22 43 68 65 63 6b 69 6e 67 20 63 ort* "Checking c
a8e0: 70 75 6c 6f 61 64 20 6f 6e 20 22 20 28 6f 72 20 puload on " (or
a8f0: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 6c 6f 63 remote-host "loc
a900: 61 6c 68 6f 73 74 22 29 20 22 2c 20 6d 61 78 6c alhost") ", maxl
a910: 6f 61 64 3a 20 22 20 6d 61 78 6c 6f 61 64 0a 09 oad: " maxload..
a920: 09 20 20 20 20 20 20 22 2c 20 6c 6f 61 64 3a 20 . ", load:
a930: 22 20 66 69 72 73 74 20 22 2c 20 61 64 6a 6c 6f " first ", adjlo
a940: 61 64 3a 20 22 20 61 64 6a 6c 6f 61 64 20 22 2c ad: " adjload ",
a950: 20 6c 6f 61 64 6a 6d 70 3a 20 22 20 6c 6f 61 64 loadjmp: " load
a960: 6a 6d 70 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 jmp). (cond.
a970: 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 69 72 ((and (> fir
a980: 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 20 st adjload)..
a990: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 (> count 0)).
a9a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
a9b0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
a9c0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 76 65 log-port* "serve
a9d0: 72 20 73 74 61 72 74 20 64 65 6c 61 79 65 64 20 r start delayed
a9e0: 22 20 61 64 6a 77 61 69 74 20 22 20 73 65 63 6f " adjwait " seco
a9f0: 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 64 20 nds due to load
aa00: 22 20 66 69 72 73 74 20 22 20 65 78 63 65 65 64 " first " exceed
aa10: 69 6e 67 20 6d 61 78 20 6f 66 20 22 20 61 64 6a ing max of " adj
aa20: 6c 6f 61 64 20 22 20 6f 6e 20 73 65 72 76 65 72 load " on server
aa30: 20 22 20 28 6f 72 20 72 65 6d 6f 74 65 2d 68 6f " (or remote-ho
aa40: 73 74 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d st (get-host-nam
aa50: 65 29 29 20 22 20 28 6e 6f 72 6d 61 6c 69 7a 65 e)) " (normalize
aa60: 64 20 6c 6f 61 64 2d 6c 69 6d 69 74 3a 20 22 20 d load-limit: "
aa70: 6d 61 78 6c 6f 61 64 20 22 29 20 22 20 28 69 66 maxload ") " (if
aa80: 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 msg msg "")).
aa90: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
aaa0: 70 21 20 61 64 6a 77 61 69 74 29 0a 20 20 20 20 p! adjwait).
aab0: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 (common:wait-f
aac0: 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f or-cpuload maxlo
aad0: 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 ad numcpus waitd
aae0: 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 elay count: (- c
aaf0: 6f 75 6e 74 20 31 29 20 6d 73 67 3a 20 6d 73 67 ount 1) msg: msg
ab00: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 3a 20 72 65 remote-host: re
ab10: 6d 6f 74 65 2d 68 6f 73 74 29 29 0a 20 20 20 20 mote-host)).
ab20: 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a 6d ((and (> loadjm
ab30: 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 20 20 28 p numcpus).. (
ab40: 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 > count 0)).
ab50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
ab60: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
ab70: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 6e og-port* "waitin
ab80: 67 20 22 20 61 64 6a 77 61 69 74 20 22 20 73 65 g " adjwait " se
ab90: 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 conds due to loa
aba0: 64 20 6a 75 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 d jump " loadjmp
abb0: 20 22 20 3e 20 6e 75 6d 63 70 75 73 20 22 20 6e " > numcpus " n
abc0: 75 6d 63 70 75 73 20 28 69 66 20 6d 73 67 20 6d umcpus (if msg m
abd0: 73 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 sg "")). (t
abe0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 61 64 6a hread-sleep! adj
abf0: 77 61 69 74 29 0a 20 20 20 20 20 20 28 63 6f 6d wait). (com
ac00: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 mon:wait-for-cpu
ac10: 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d load maxload num
ac20: 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 63 cpus waitdelay c
ac30: 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 31 ount: (- count 1
ac40: 29 20 6d 73 67 3a 20 6d 73 67 20 72 65 6d 6f 74 ) msg: msg remot
ac50: 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 65 2d 68 e-host: remote-h
ac60: 6f 73 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ost)))))..(defin
ac70: 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 e (common:wait-f
ac80: 6f 72 2d 68 6f 6d 65 68 6f 73 74 2d 6c 6f 61 64 or-homehost-load
ac90: 20 6d 61 78 6c 6f 61 64 20 6d 73 67 29 0a 20 20 maxload msg).
aca0: 28 6c 65 74 2a 20 28 28 68 68 2d 64 61 74 20 28 (let* ((hh-dat (
acb0: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f if (common:on-ho
acc0: 6d 65 68 6f 73 74 3f 29 20 3b 3b 20 69 66 20 77 mehost?) ;; if w
acd0: 65 20 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d e are on the hom
ace0: 65 68 6f 73 74 20 74 68 65 6e 20 70 61 73 73 20 ehost then pass
acf0: 69 6e 20 23 66 20 73 6f 20 74 68 65 20 63 61 6c in #f so the cal
ad00: 6c 73 20 61 72 65 20 6c 6f 63 61 6c 2e 0a 20 20 ls are local..
ad10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad20: 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 #f.
ad30: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d (comm
ad40: 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 on:get-homehost)
ad50: 29 29 0a 20 20 20 20 20 20 20 20 20 28 68 68 20 )). (hh
ad60: 20 20 20 20 28 69 66 20 68 68 2d 64 61 74 20 28 (if hh-dat (
ad70: 63 61 72 20 68 68 2d 64 61 74 29 20 23 66 29 29 car hh-dat) #f))
ad80: 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 63 70 . (numcp
ad90: 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e us (common:get-n
ada0: 75 6d 2d 63 70 75 73 20 68 68 29 29 29 0a 20 20 um-cpus hh))).
adb0: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 (common:wait-f
adc0: 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f or-normalized-lo
add0: 61 64 20 6d 61 78 6c 6f 61 64 20 6d 73 67 20 68 ad maxload msg h
ade0: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 h)))..(define (c
adf0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 ommon:get-num-cp
ae00: 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a us remote-host).
ae10: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 75 61 6c (let* ((actual
ae20: 2d 68 6f 73 74 20 28 6f 72 20 72 65 6d 6f 74 65 -host (or remote
ae30: 2d 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 2d -host (get-host-
ae40: 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 6f 72 name)))). (or
ae50: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 61 63 (common:get-cac
ae60: 68 65 64 2d 69 6e 66 6f 20 61 63 74 75 61 6c 2d hed-info actual-
ae70: 68 6f 73 74 20 22 6e 75 6d 2d 63 70 75 73 22 20 host "num-cpus"
ae80: 61 67 65 3a 20 38 36 34 30 30 29 20 3b 3b 20 68 age: 86400) ;; h
ae90: 6f 73 74 73 20 68 61 64 20 62 65 74 74 65 72 20 osts had better
aea0: 6e 6f 74 20 62 65 20 63 68 61 6e 67 69 6e 67 20 not be changing
aeb0: 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 63 70 the number of cp
aec0: 75 73 20 74 6f 6f 20 6f 66 74 65 6e 21 0a 09 28 us too often!..(
aed0: 6c 65 74 2a 20 28 28 70 72 6f 63 20 20 20 28 6c let* ((proc (l
aee0: 61 6d 62 64 61 20 28 29 0a 09 09 09 20 28 6c 65 ambda ().... (le
aef0: 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 75 20 t loop ((numcpu
af00: 30 29 0a 09 09 09 09 20 20 20 20 28 69 6e 6c 20 0)..... (inl
af10: 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 (read-line)))
af20: 0a 09 09 09 20 20 20 28 69 66 20 28 65 6f 66 2d .... (if (eof-
af30: 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 09 object? inl)....
af40: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
af50: 09 09 20 28 63 6f 6d 6d 6f 6e 3a 77 72 69 74 65 .. (common:write
af60: 2d 63 61 63 68 65 64 2d 69 6e 66 6f 20 72 65 6d -cached-info rem
af70: 6f 74 65 2d 68 6f 73 74 20 22 6e 75 6d 2d 63 70 ote-host "num-cp
af80: 75 73 22 20 6e 75 6d 63 70 75 29 0a 09 09 09 09 us" numcpu).....
af90: 20 6e 75 6d 63 70 75 29 0a 09 09 09 20 20 20 20 numcpu)....
afa0: 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 73 74 (loop (if (st
afb0: 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 72 6f ring-match "^pro
afc0: 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c cessor\\s+:\\s+\
afd0: 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 09 09 \d+$" inl)......
afe0: 20 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 (+ numcpu 1)...
aff0: 09 09 09 20 6e 75 6d 63 70 75 29 0a 09 09 09 09 ... numcpu).....
b000: 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 (read-line)
b010: 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 72 ))))).. (r
b020: 65 73 75 6c 74 20 28 69 66 20 72 65 6d 6f 74 65 esult (if remote
b030: 2d 68 6f 73 74 0a 09 09 09 20 20 20 28 77 69 74 -host.... (wit
b040: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
b050: 65 20 0a 09 09 09 20 20 20 20 20 20 20 28 63 6f e .... (co
b060: 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f 74 65 nc "ssh " remote
b070: 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 72 6f -host " cat /pro
b080: 63 2f 63 70 75 69 6e 66 6f 22 29 0a 09 09 09 20 c/cpuinfo")....
b090: 20 20 20 20 70 72 6f 63 29 0a 09 09 09 20 20 20 proc)....
b0a0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
b0b0: 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 75 -file "/proc/cpu
b0c0: 69 6e 66 6f 22 20 70 72 6f 63 29 29 29 29 0a 09 info" proc))))..
b0d0: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 72 69 74 65 2d (common:write-
b0e0: 63 61 63 68 65 64 2d 69 6e 66 6f 20 61 63 74 75 cached-info actu
b0f0: 61 6c 2d 68 6f 73 74 20 22 6e 75 6d 2d 63 70 75 al-host "num-cpu
b100: 73 22 20 72 65 73 75 6c 74 29 0a 09 20 20 72 65 s" result).. re
b110: 73 75 6c 74 29 29 29 29 0a 0a 3b 3b 20 77 61 69 sult))))..;; wai
b120: 74 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 t for normalized
b130: 20 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 6f cpu load to dro
b140: 70 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a p below maxload.
b150: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
b160: 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d on:wait-for-norm
b170: 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 6c alized-load maxl
b180: 6f 61 64 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 oad msg remote-h
b190: 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 ost). (let ((nu
b1a0: 6d 2d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 m-cpus (common:g
b1b0: 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f et-num-cpus remo
b1c0: 74 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 te-host))). (
b1d0: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
b1e0: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
b1f0: 6e 75 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a num-cpus 15 msg:
b200: 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 6f 73 74 msg remote-host
b210: 3a 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 : remote-host)))
b220: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
b230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 ==========.;; D
b270: 45 20 42 20 55 20 47 20 47 20 49 20 4e 20 47 20 E B U G G I N G
b280: 20 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d S T U F F .;;=
b290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b2d0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 69 6e =====..;; (defin
b2e0: 65 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 20 20 e *verbosity*
b2f0: 20 20 20 20 20 20 31 29 0a 3b 3b 20 28 64 65 66 1).;; (def
b300: 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 20 ine *logging*
b310: 20 20 20 20 20 20 20 20 23 66 29 0a 0a 28 64 65 #f)..(de
b320: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 fine (common:set
b330: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
b340: 6e 29 0a 20 20 28 72 6d 74 3a 73 65 74 2d 76 61 n). (rmt:set-va
b350: 72 20 22 4d 45 47 41 54 45 53 54 5f 56 45 52 53 r "MEGATEST_VERS
b360: 49 4f 4e 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 ION" (common:ver
b370: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 sion-signature))
b380: 29 0a 0a 3b 3b 20 70 6f 73 74 69 76 65 20 6e 75 )..;; postive nu
b390: 6d 62 65 72 20 69 66 20 6d 65 67 61 74 65 73 74 mber if megatest
b3a0: 20 76 65 72 73 69 6f 6e 20 3e 20 64 62 20 76 65 version > db ve
b3b0: 72 73 69 6f 6e 0a 3b 3b 20 6e 65 67 61 74 69 76 rsion.;; negativ
b3c0: 65 20 6e 75 6d 62 65 72 20 69 66 20 6d 65 67 61 e number if mega
b3d0: 74 65 73 74 20 76 65 72 73 69 6f 6e 20 3c 20 64 test version < d
b3e0: 62 20 76 65 72 73 69 6f 6e 0a 28 64 65 66 69 6e b version.(defin
b3f0: 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f e (common:versio
b400: 6e 2d 64 62 2d 64 65 6c 74 61 29 0a 20 20 20 20 n-db-delta).
b410: 20 20 20 20 20 28 2d 20 6d 65 67 61 74 65 73 74 (- megatest
b420: 2d 76 65 72 73 69 6f 6e 20 28 63 6f 6d 6d 6f 6e -version (common
b430: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
b440: 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 29 29 0a rsion-number))).
b450: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
b460: 3a 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 :version-changed
b470: 3f 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 6c ?). (not (equal
b480: 3f 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 ? (common:get-la
b490: 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a st-run-version).
b4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b4b0: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 common:version-s
b4c0: 69 67 6e 61 74 75 72 65 29 29 29 29 0a 0a 3b 3b ignature))))..;;
b4d0: 20 66 72 6f 6d 20 6d 65 74 61 64 61 74 20 6c 6f from metadat lo
b4e0: 6f 6b 75 70 20 4d 45 47 41 54 45 53 54 5f 56 45 okup MEGATEST_VE
b4f0: 52 53 49 4f 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 RSION.;;.(define
b500: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
b510: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 3b t-run-version) ;
b520: 3b 20 52 41 44 54 20 3d 3e 20 48 6f 77 20 64 6f ; RADT => How do
b530: 65 73 20 74 68 69 73 20 77 6f 72 6b 20 69 6e 20 es this work in
b540: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 66 75 6e send-receive fun
b550: 63 74 69 6f 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 ction??; assume
b560: 69 74 20 69 73 20 74 68 65 20 76 61 6c 75 65 20 it is the value
b570: 73 61 76 65 64 20 69 6e 20 73 6f 6d 65 20 44 42 saved in some DB
b580: 0a 20 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 . (rmt:get-var
b590: 22 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f "MEGATEST_VERSIO
b5a0: 4e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 N"))..(define (c
b5b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
b5c0: 75 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 un-version-numbe
b5d0: 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 r). (string->nu
b5e0: 6d 62 65 72 20 0a 20 20 20 28 73 75 62 73 74 72 mber . (substr
b5f0: 69 6e 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ing (common:get-
b600: 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e last-run-version
b610: 29 20 30 20 36 29 29 29 0a 0a 28 64 65 66 69 6e ) 0 6)))..(defin
b620: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 e (common:api-ch
b630: 61 6e 67 65 64 3f 29 0a 20 20 28 6e 6f 74 20 28 anged?). (not (
b640: 65 71 75 61 6c 3f 20 28 73 75 62 73 74 72 69 6e equal? (substrin
b650: 67 20 28 2d 3e 73 74 72 69 6e 67 20 6d 65 67 61 g (->string mega
b660: 74 65 73 74 2d 76 65 72 73 69 6f 6e 29 20 30 20 test-version) 0
b670: 34 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 4).
b680: 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 6f (substring (co
b690: 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c nc (common:get-l
b6a0: 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 ast-run-version)
b6b0: 29 20 30 20 34 29 29 29 29 0a 0a 3b 3b 20 27 28 ) 0 4))))..;; '(
b6c0: 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d 69 6e print (string-in
b6d0: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 tersperse (map c
b6e0: 61 64 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d adr (hash-table-
b6f0: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 72 65 61 ref/default (rea
b700: 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 d-config "megate
b710: 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 66 20 5c st.config" \#f \
b720: 23 74 29 20 22 64 69 73 6b 73 22 20 27 22 27 22 #t) "disks" '"'"
b730: 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 20 22 '("none" ""))) "
b740: 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e 65 20 28 \n"))'.(define (
b750: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 73 common:get-disks
b760: 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 #!key (configf
b770: 23 66 29 29 0a 20 20 28 68 61 73 68 2d 74 61 62 #f)). (hash-tab
b780: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a le-ref/default .
b790: 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 28 (or configf (
b7a0: 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 63 6f 6e configf:read-con
b7b0: 66 69 67 20 22 6d 65 67 61 74 65 73 74 2e 63 6f fig "megatest.co
b7c0: 6e 66 69 67 22 20 23 66 20 23 74 29 29 0a 20 20 nfig" #f #t)).
b7d0: 20 22 64 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 "disks" '("none
b7e0: 22 20 22 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d " "")))..;;=====
b7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b830: 3d 0a 3b 3b 20 77 61 74 63 68 64 6f 67 20 61 6e =.;; watchdog an
b840: 64 20 65 78 69 74 20 70 72 6f 63 65 64 75 72 65 d exit procedure
b850: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
b860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d ==========..;;==
b8a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8e0: 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 20 ====.;; E X I T
b8f0: 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 H A N D L I N
b900: 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;============
b910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
b950: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d ine (common:run-
b960: 73 79 6e 63 3f 29 0a 20 20 20 20 28 61 6e 64 20 sync?). (and
b970: 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 (common:on-homeh
b980: 6f 73 74 3f 29 0a 09 20 28 61 72 67 73 3a 67 65 ost?).. (args:ge
b990: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
b9a0: 29 29 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 ))..;; (let ((
b9b0: 6f 68 68 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 ohh (common:on-h
b9c0: 6f 6d 65 68 6f 73 74 3f 29 29 0a 3b 3b 20 09 28 omehost?)).;; .(
b9d0: 73 72 76 20 28 61 72 67 73 3a 67 65 74 2d 61 72 srv (args:get-ar
b9e0: 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a 3b g "-server"))).;
b9f0: 3b 20 20 20 20 20 28 61 6e 64 20 6f 68 68 20 73 ; (and ohh s
ba00: 72 76 29 29 29 0a 20 20 20 20 3b 3b 20 28 64 65 rv))). ;; (de
ba10: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
ba20: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
ba30: 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d rt* "common:run-
ba40: 73 79 6e 63 3f 20 6f 68 68 3d 22 20 6f 68 68 20 sync? ohh=" ohh
ba50: 22 2c 20 73 72 76 3d 22 20 73 72 76 29 0a 0a 28 ", srv=" srv)..(
ba60: 64 65 66 69 6e 65 20 2a 77 61 74 63 68 64 6f 67 define *watchdog
ba70: 2a 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 * (make-thread..
ba80: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
ba90: 09 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d .. (handle-
baa0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 exceptions....
bab0: 65 78 6e 0a 09 09 09 20 20 28 62 65 67 69 6e 0a exn.... (begin.
bac0: 09 09 09 20 20 20 20 28 70 72 69 6e 74 2d 63 61 ... (print-ca
bad0: 6c 6c 2d 63 68 61 69 6e 29 0a 09 09 09 20 20 20 ll-chain)....
bae0: 20 28 70 72 69 6e 74 20 22 20 6d 65 73 73 61 67 (print " messag
baf0: 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
bb00: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
bb10: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
bb20: 29 20 65 78 6e 29 29 29 0a 09 09 09 28 63 6f 6d ) exn)))....(com
bb30: 6d 6f 6e 3a 77 61 74 63 68 64 6f 67 29 29 29 0a mon:watchdog))).
bb40: 09 09 20 20 20 20 22 57 61 74 63 68 64 6f 67 20 .. "Watchdog
bb50: 74 68 72 65 61 64 22 29 29 0a 0a 3b 3b 20 63 75 thread"))..;; cu
bb60: 72 72 65 6e 74 6c 79 20 74 68 65 20 70 72 69 6d rrently the prim
bb70: 61 72 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 77 ary job of the w
bb80: 61 74 63 68 64 6f 67 20 69 73 20 74 6f 20 72 75 atchdog is to ru
bb90: 6e 20 74 68 65 20 73 79 6e 63 20 62 61 63 6b 20 n the sync back
bba0: 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 66 to megatest.db f
bbb0: 72 6f 6d 20 74 68 65 20 64 62 20 69 6e 20 2f 74 rom the db in /t
bbc0: 6d 70 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 20 mp.;; if we are
bbd0: 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 on the homehost
bbe0: 61 6e 64 20 77 65 20 61 72 65 20 61 20 73 65 72 and we are a ser
bbf0: 76 65 72 20 28 62 79 20 64 65 66 69 6e 69 74 69 ver (by definiti
bc00: 6f 6e 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 on we are on the
bc10: 20 68 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 20 homehost if we
bc20: 61 72 65 20 61 20 73 65 72 76 65 72 29 0a 3b 3b are a server).;;
bc30: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
bc40: 3a 72 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 :readonly-watchd
bc50: 6f 67 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 og dbstruct). (
bc60: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
bc70: 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 05) ;; delay for
bc80: 20 73 74 61 72 74 75 70 0a 20 20 28 64 65 62 75 startup. (debu
bc90: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
bca0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
bcb0: 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 65 61 64 6f t* "common:reado
bcc0: 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 65 6e 74 nly-watchdog ent
bcd0: 65 72 65 64 2e 22 29 0a 20 20 3b 3b 20 73 79 6e ered."). ;; syn
bce0: 63 20 6d 65 67 61 74 65 73 74 2e 64 62 20 74 6f c megatest.db to
bcf0: 20 2f 74 6d 70 2f 2e 2e 2e 2f 6d 65 67 61 74 73 /tmp/.../megats
bd00: 74 2e 64 62 0a 20 20 28 6c 65 74 2a 20 28 28 73 t.db. (let* ((s
bd10: 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 ync-cool-off-dur
bd20: 61 74 69 6f 6e 20 20 20 33 29 0a 20 20 20 20 20 ation 3).
bd30: 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 64 62 20 (golden-mtdb
bd40: 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 (dbr:dbstruc
bd50: 74 2d 6d 74 64 62 20 64 62 73 74 72 75 63 74 29 t-mtdb dbstruct)
bd60: 29 0a 20 20 20 20 20 20 20 20 28 67 6f 6c 64 65 ). (golde
bd70: 6e 2d 6d 74 70 61 74 68 20 20 20 28 64 62 3a 64 n-mtpath (db:d
bd80: 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 67 6f bdat-get-path go
bd90: 6c 64 65 6e 2d 6d 74 64 62 29 29 0a 20 20 20 20 lden-mtdb)).
bda0: 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 20 20 20 (tmp-mtdb
bdb0: 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 (dbr:dbstru
bdc0: 63 74 2d 74 6d 70 64 62 20 64 62 73 74 72 75 63 ct-tmpdb dbstruc
bdd0: 74 29 29 0a 20 20 20 20 20 20 20 20 28 74 6d 70 t)). (tmp
bde0: 2d 6d 74 70 61 74 68 20 20 20 20 20 20 28 64 62 -mtpath (db
bdf0: 3a 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 :dbdat-get-path
be00: 74 6d 70 2d 6d 74 64 62 29 29 29 0a 20 20 20 20 tmp-mtdb))).
be10: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
be20: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
be30: 2d 70 6f 72 74 2a 20 22 52 65 61 64 2d 6f 6e 6c -port* "Read-onl
be40: 79 20 70 65 72 69 6f 64 69 63 20 73 79 6e 63 20 y periodic sync
be50: 74 68 72 65 61 64 20 73 74 61 72 74 65 64 2e 22 thread started."
be60: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
be70: 28 28 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 ((last-sync-time
be80: 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 0)). (debu
be90: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
bea0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
beb0: 74 2a 20 22 6c 6f 6f 70 20 74 6f 70 20 74 6d 70 t* "loop top tmp
bec0: 2d 6d 74 70 61 74 68 3d 22 74 6d 70 2d 6d 74 70 -mtpath="tmp-mtp
bed0: 61 74 68 22 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 ath" golden-mtpa
bee0: 74 68 3d 22 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 th="golden-mtpat
bef0: 68 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 h). (let* (
bf00: 28 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d (duration-since-
bf10: 6c 61 73 74 2d 73 79 6e 63 20 28 2d 20 28 63 75 last-sync (- (cu
bf20: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c rrent-seconds) l
bf30: 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 29 29 ast-sync-time)))
bf40: 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
bf50: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
bf60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
bf70: 20 22 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 "duration-since
bf80: 2d 6c 61 73 74 2d 73 79 6e 63 3d 22 64 75 72 61 -last-sync="dura
bf90: 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 2d tion-since-last-
bfa0: 73 79 6e 63 29 0a 20 20 20 20 20 20 20 20 28 69 sync). (i
bfb0: 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d f (and (not *tim
bfc0: 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 e-to-exit*).
bfd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3c 20 (<
bfe0: 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c duration-since-l
bff0: 61 73 74 2d 73 79 6e 63 20 73 79 6e 63 2d 63 6f ast-sync sync-co
c000: 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 6f 6e 29 ol-off-duration)
c010: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 74 ). (t
c020: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2d 20 hread-sleep! (-
c030: 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 sync-cool-off-du
c040: 72 61 74 69 6f 6e 20 64 75 72 61 74 69 6f 6e 2d ration duration-
c050: 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 29 since-last-sync)
c060: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
c070: 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 not *time-to-exi
c080: 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t*).
c090: 28 6c 65 74 20 28 28 67 6f 6c 64 65 6e 2d 6d 74 (let ((golden-mt
c0a0: 64 62 2d 6d 74 69 6d 65 20 28 66 69 6c 65 2d 6d db-mtime (file-m
c0b0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
c0c0: 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 29 golden-mtpath))
c0d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c0e0: 20 20 20 28 74 6d 70 2d 6d 74 64 62 2d 6d 74 69 (tmp-mtdb-mti
c0f0: 6d 65 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 me (file-modi
c100: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 74 6d fication-time tm
c110: 70 2d 6d 74 70 61 74 68 29 29 29 0a 09 20 20 20 p-mtpath)))..
c120: 20 20 20 28 69 66 20 28 3e 20 67 6f 6c 64 65 6e (if (> golden
c130: 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 74 6d 70 2d -mtdb-mtime tmp-
c140: 6d 74 64 62 2d 6d 74 69 6d 65 29 0a 09 09 20 20 mtdb-mtime)...
c150: 28 69 66 20 28 3c 20 67 6f 6c 64 65 6e 2d 6d 74 (if (< golden-mt
c160: 64 62 2d 6d 74 69 6d 65 20 28 2d 20 28 63 75 72 db-mtime (- (cur
c170: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 33 29 rent-seconds) 3)
c180: 29 20 3b 3b 20 66 69 6c 65 20 68 61 73 20 4e 4f ) ;; file has NO
c190: 54 20 62 65 65 6e 20 74 6f 75 63 68 65 64 20 69 T been touched i
c1a0: 6e 20 70 61 73 74 20 74 68 72 65 65 20 73 65 63 n past three sec
c1b0: 6f 6e 64 73 2c 20 74 68 69 73 20 77 61 79 20 6d onds, this way m
c1c0: 75 6c 74 69 70 6c 65 20 73 65 72 76 65 72 73 20 ultiple servers
c1d0: 77 6f 6e 27 74 20 66 69 67 68 74 20 74 6f 20 73 won't fight to s
c1e0: 79 6e 63 20 62 61 63 6b 0a 09 09 20 20 20 20 20 ync back...
c1f0: 20 28 6c 65 74 20 28 28 72 65 73 20 28 64 62 3a (let ((res (db:
c200: 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 64 62 multi-db-sync db
c210: 73 74 72 75 63 74 20 27 6f 6c 64 32 6e 65 77 29 struct 'old2new)
c220: 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 ))....(debug:pri
c230: 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 nt-info 13 *defa
c240: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
c250: 6f 73 79 6e 63 20 63 61 6c 6c 65 64 2c 20 22 20 osync called, "
c260: 72 65 73 20 22 20 72 65 63 6f 72 64 73 20 74 72 res " records tr
c270: 61 6e 73 66 65 72 72 65 64 2e 22 29 29 29 29 0a ansferred.")))).
c280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
c290: 6f 6f 70 20 28 63 75 72 72 65 6e 74 2d 73 65 63 oop (current-sec
c2a0: 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 20 20 onds))).
c2b0: 20 20 20 20 23 74 29 29 29 0a 20 20 20 20 28 64 #t))). (d
c2c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
c2d0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
c2e0: 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 72 65 ort* "Exiting re
c2f0: 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 adonly-watchdog
c300: 74 69 6d 65 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d timer, *time-to-
c310: 65 78 69 74 2a 20 3d 20 22 20 2a 74 69 6d 65 2d exit* = " *time-
c320: 74 6f 2d 65 78 69 74 2a 22 20 70 69 64 3d 22 28 to-exit*" pid="(
c330: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
c340: 69 64 29 22 20 6d 74 70 61 74 68 3d 22 67 6f 6c id)" mtpath="gol
c350: 64 65 6e 2d 6d 74 70 61 74 68 29 29 29 0a 0a 0a den-mtpath)))...
c360: 3b 3b 20 54 4f 44 4f 3a 20 66 6f 72 20 6d 75 6c ;; TODO: for mul
c370: 74 69 70 6c 65 20 61 72 65 61 73 2c 20 77 65 20 tiple areas, we
c380: 77 69 6c 6c 20 68 61 76 65 20 6d 75 6c 74 69 70 will have multip
c390: 6c 65 20 77 61 74 63 68 64 6f 67 73 3b 20 61 6e le watchdogs; an
c3a0: 64 20 6d 75 6c 74 69 70 6c 65 20 74 68 72 65 61 d multiple threa
c3b0: 64 73 20 74 6f 20 6d 61 6e 61 67 65 0a 28 64 65 ds to manage.(de
c3c0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 74 fine (common:wat
c3d0: 63 68 64 6f 67 29 0a 20 20 28 64 65 62 75 67 3a chdog). (debug:
c3e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
c3f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
c400: 20 22 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 64 6f "common:watchdo
c410: 67 20 65 6e 74 65 72 65 64 2e 22 29 0a 20 20 28 g entered."). (
c420: 69 66 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 if (launch:setup
c430: 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d ). (if (com
c440: 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f mon:on-homehost?
c450: 29 0a 09 20 20 28 6c 65 74 20 28 28 64 62 73 74 ).. (let ((dbst
c460: 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 20 23 ruct (db:setup #
c470: 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 t))).. (debug
c480: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a :print-info 13 *
c490: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
c4a0: 2a 20 22 61 66 74 65 72 20 64 62 3a 73 65 74 75 * "after db:setu
c4b0: 70 20 77 69 74 68 20 64 62 73 74 72 75 63 74 3d p with dbstruct=
c4c0: 22 20 64 62 73 74 72 75 63 74 29 0a 09 20 20 20 " dbstruct)..
c4d0: 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 64 (cond.. ((d
c4e0: 62 72 3a 64 62 73 74 72 75 63 74 2d 72 65 61 64 br:dbstruct-read
c4f0: 2d 6f 6e 6c 79 20 64 62 73 74 72 75 63 74 29 0a -only dbstruct).
c500: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
c510: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
c520: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
c530: 6c 6f 61 64 69 6e 67 20 72 65 61 64 2d 6f 6e 6c loading read-onl
c540: 79 20 77 61 74 63 68 64 6f 67 22 29 0a 09 20 20 y watchdog")..
c550: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 (common:read
c560: 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 64 62 only-watchdog db
c570: 73 74 72 75 63 74 29 29 0a 09 20 20 20 20 20 28 struct)).. (
c580: 65 6c 73 65 0a 09 20 20 20 20 20 20 28 64 65 62 else.. (deb
c590: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
c5a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
c5b0: 72 74 2a 20 22 6c 6f 61 64 69 6e 67 20 77 72 69 rt* "loading wri
c5c0: 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 2e 22 table-watchdog."
c5d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c5e0: 28 6c 65 74 2a 20 28 28 73 79 6e 63 65 72 20 28 (let* ((syncer (
c5f0: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
c600: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
c610: 73 65 72 76 65 72 22 20 22 73 79 6e 63 2d 6d 65 server" "sync-me
c620: 74 68 6f 64 22 29 20 22 62 72 75 74 65 2d 66 6f thod") "brute-fo
c630: 72 63 65 2d 73 79 6e 63 22 29 29 29 0a 20 20 20 rce-sync"))).
c640: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
c650: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
c660: 20 20 20 20 28 28 65 71 75 61 6c 3f 20 73 79 6e ((equal? syn
c670: 63 65 72 20 22 62 72 75 74 65 2d 66 6f 72 63 65 cer "brute-force
c680: 2d 73 79 6e 63 22 29 0a 20 20 20 20 20 20 20 20 -sync").
c690: 20 20 20 20 20 20 20 20 20 20 28 73 65 72 76 65 (serve
c6a0: 72 3a 77 72 69 74 61 62 6c 65 2d 77 61 74 63 68 r:writable-watch
c6b0: 64 6f 67 2d 62 72 75 74 65 66 6f 72 63 65 20 64 dog-bruteforce d
c6c0: 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 20 20 bstruct)).
c6d0: 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 75 ((equ
c6e0: 61 6c 3f 20 73 79 6e 63 65 72 20 22 64 65 6c 74 al? syncer "delt
c6f0: 61 2d 73 79 6e 63 22 29 0a 20 20 20 20 20 20 20 a-sync").
c700: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 72 76 (serv
c710: 65 72 3a 77 72 69 74 61 62 6c 65 2d 77 61 74 63 er:writable-watc
c720: 68 64 6f 67 2d 64 65 6c 74 61 73 79 6e 63 20 64 hdog-deltasync d
c730: 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 20 20 bstruct)).
c740: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
c750: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c760: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
c770: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
c780: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 6b 6e -log-port* "Unkn
c790: 6f 77 6e 20 73 65 72 76 65 72 2f 73 79 6e 63 2d own server/sync-
c7a0: 6d 65 74 68 6f 64 20 73 70 65 63 69 66 69 65 64 method specified
c7b0: 20 28 22 73 79 6e 63 65 72 22 29 20 2d 20 76 61 ("syncer") - va
c7c0: 6c 69 64 20 76 61 6c 75 65 73 20 61 72 65 20 62 lid values are b
c7d0: 72 75 74 65 2d 66 6f 72 63 65 2d 73 79 6e 63 20 rute-force-sync
c7e0: 61 6e 64 20 64 65 6c 74 61 2d 73 79 6e 63 2e 22 and delta-sync."
c7f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c800: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 (exit 1))).
c810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
c820: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 ;(debug:print 1
c830: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
c840: 74 2a 20 22 49 4e 46 4f 3a 20 5b 22 28 63 6f 6d t* "INFO: ["(com
c850: 6d 6f 6e 3a 68 75 6d 61 6e 2d 74 69 6d 65 29 22 mon:human-time)"
c860: 5d 20 53 79 6e 63 65 72 20 73 74 61 72 74 65 64 ] Syncer started
c870: 20 28 6d 65 74 68 6f 64 3d 22 73 79 6e 63 65 72 (method="syncer
c880: 22 29 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 ")").
c890: 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 64 ))).. (d
c8a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
c8b0: 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 13 *default-log-
c8c0: 70 6f 72 74 2a 20 22 77 61 74 63 68 64 6f 67 20 port* "watchdog
c8d0: 64 6f 6e 65 2e 22 29 29 0a 09 20 20 28 64 65 62 done.")).. (deb
c8e0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
c8f0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
c900: 72 74 2a 20 22 6e 6f 20 6e 65 65 64 20 66 6f 72 rt* "no need for
c910: 20 77 61 74 63 68 64 6f 67 20 6f 6e 20 6e 6f 6e watchdog on non
c920: 2d 68 6f 6d 65 68 6f 73 74 22 29 29 29 29 0a 0a -homehost"))))..
c930: 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 65 78 .(define (std-ex
c940: 69 74 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 20 it-procedure).
c950: 3b 3b 28 63 6f 6d 6d 6f 6e 3a 74 65 6c 65 6d 65 ;;(common:teleme
c960: 74 72 79 2d 6c 6f 67 2d 63 6c 6f 73 65 29 0a 20 try-log-close).
c970: 20 28 6f 6e 2d 65 78 69 74 20 28 6c 61 6d 62 64 (on-exit (lambd
c980: 61 20 28 29 20 30 29 29 0a 20 20 3b 3b 28 64 65 a () 0)). ;;(de
c990: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
c9a0: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
c9b0: 6f 72 74 2a 20 22 73 74 64 2d 65 78 69 74 2d 70 ort* "std-exit-p
c9c0: 72 6f 63 65 64 75 72 65 20 63 61 6c 6c 65 64 3b rocedure called;
c9d0: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d *time-to-exit*=
c9e0: 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 "*time-to-exit*)
c9f0: 0a 20 20 28 6c 65 74 20 28 28 6e 6f 2d 68 75 72 . (let ((no-hur
ca00: 72 79 20 20 28 69 66 20 2a 74 69 6d 65 2d 74 6f ry (if *time-to
ca10: 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 72 79 20 -exit* ;; hurry
ca20: 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 0a 09 up... #f..
ca30: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
ca40: 09 09 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 .. (set! *time-t
ca50: 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 09 20 o-exit* #t)....
ca60: 23 74 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 #t)))). (debu
ca70: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
ca80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
ca90: 2a 20 22 73 74 61 72 74 69 6e 67 20 65 78 69 74 * "starting exit
caa0: 20 70 72 6f 63 65 73 73 2c 20 66 69 6e 61 6c 69 process, finali
cab0: 7a 69 6e 67 20 64 61 74 61 62 61 73 65 73 2e 22 zing databases."
cac0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 6e ). (if (and n
cad0: 6f 2d 68 75 72 72 79 20 28 64 65 62 75 67 3a 64 o-hurry (debug:d
cae0: 65 62 75 67 2d 6d 6f 64 65 20 31 38 29 29 0a 09 ebug-mode 18))..
caf0: 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 (rmt:print-db-st
cb00: 61 74 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 ats)). (let (
cb10: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
cb20: 64 20 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 d (lambda () ;;
cb30: 74 68 72 65 61 64 20 66 6f 72 20 63 6c 65 61 6e thread for clean
cb40: 69 6e 67 20 75 70 2c 20 67 69 76 65 20 69 74 20 ing up, give it
cb50: 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 five seconds.
cb60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb70: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 2a (if *
cb80: 64 62 73 74 72 75 63 74 2d 64 62 2a 20 28 64 62 dbstruct-db* (db
cb90: 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 73 74 :close-all *dbst
cba0: 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b 20 6f 6e ruct-db*)) ;; on
cbb0: 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 61 74 e second allocat
cbc0: 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ed.... (if
cbd0: 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 09 *task-db* ...
cbe0: 09 09 20 20 28 6c 65 74 20 28 28 64 62 20 28 63 .. (let ((db (c
cbf0: 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 0a dr *task-db*))).
cc00: 09 09 09 09 20 20 20 20 28 69 66 20 28 73 71 6c .... (if (sql
cc10: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 ite3:database? d
cc20: 62 29 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 b)......(begin..
cc30: 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 69 .... (sqlite3:i
cc40: 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a 09 09 nterrupt! db)...
cc50: 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 ... (sqlite3:fi
cc60: 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 29 0a 09 nalize! db #t)..
cc70: 09 09 09 09 20 20 3b 3b 20 28 76 65 63 74 6f 72 .... ;; (vector
cc80: 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 -set! *task-db*
cc90: 30 20 23 66 29 0a 09 09 09 09 09 20 20 28 73 65 0 #f)...... (se
cca0: 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 23 66 29 t! *task-db* #f)
ccb0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
ccc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ccd0: 20 20 20 28 68 74 74 70 2d 63 6c 69 65 6e 74 23 (http-client#
cce0: 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 close-all-connec
ccf0: 74 69 6f 6e 73 21 29 0a 20 20 20 20 20 20 20 20 tions!).
cd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd10: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 61 6e ;; (if (an
cd20: 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 20 d *runremote*.
cd30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd40: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
cd50: 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d (remote-
cd60: 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f conndat *runremo
cd70: 74 65 2a 29 29 0a 20 20 20 20 20 20 20 20 20 20 te*)).
cd80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd90: 20 20 20 20 3b 3b 20 20 20 20 20 28 62 65 67 69 ;; (begi
cda0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
cdb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cdc0: 3b 3b 20 20 20 20 20 20 20 28 68 74 74 70 2d 63 ;; (http-c
cdd0: 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c 2d lient#close-all-
cde0: 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 20 connections!)))
cdf0: 3b 3b 20 66 6f 72 20 68 74 74 70 2d 63 6c 69 65 ;; for http-clie
ce00: 6e 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nt.
ce10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce20: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a (if (not (eq? *
ce30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
ce40: 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 * (current-error
ce50: 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 -port))).
ce60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce70: 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 (clos
ce80: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 e-output-port *d
ce90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
cea0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 )).... (set
ceb0: 21 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 ! *default-log-p
cec0: 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 ort* (current-er
ced0: 72 6f 72 2d 70 6f 72 74 29 29 29 20 22 43 6c 65 ror-port))) "Cle
cee0: 61 6e 75 70 20 64 62 20 65 78 69 74 20 74 68 72 anup db exit thr
cef0: 65 61 64 22 29 29 0a 09 20 20 28 74 68 32 20 28 ead")).. (th2 (
cf00: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
cf10: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
cf20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
cf30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
cf40: 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 63 6c * "Attempting cl
cf50: 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 ean exit. Please
cf60: 20 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 be patient and
cf70: 77 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e wait a few secon
cf80: 64 73 2e 2e 2e 22 29 0a 09 09 09 20 20 20 20 20 ds...")....
cf90: 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 0a 20 20 (if no-hurry.
cfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfc0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
cfd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfe0: 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 (thre
cff0: 61 64 2d 73 6c 65 65 70 21 20 35 29 29 20 3b 3b ad-sleep! 5)) ;;
d000: 20 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 give the clean
d010: 75 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 up few seconds t
d020: 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a o do it's stuff.
d030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d050: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 09 (begin. .
d060: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
d070: 65 70 21 20 32 29 29 29 0a 20 20 20 20 20 20 09 ep! 2))). .
d080: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
d090: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
d0a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 log-port* " ...
d0b0: 64 6f 6e 65 22 29 0a 20 20 20 20 20 20 09 09 09 done"). ...
d0c0: 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 22 ).... "
d0d0: 63 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a 20 clean exit"))).
d0e0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta
d0f0: 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 28 rt! th1). (
d100: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
d110: 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2). (thread
d120: 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 20 -join! th1).
d130: 20 20 29 0a 20 20 20 20 29 0a 0a 20 20 30 29 0a ). ).. 0).
d140: 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 73 69 .(define (std-si
d150: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 gnal-handler sig
d160: 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 6e 61 num). ;; (signa
d170: 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a l-mask! signum).
d180: 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f (set! *time-to
d190: 2d 65 78 69 74 2a 20 23 74 29 20 0a 20 20 3b 3b -exit* #t) . ;;
d1a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
d1b0: 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 13 *default-lo
d1c0: 67 2d 70 6f 72 74 2a 20 22 67 6f 74 20 73 69 67 g-port* "got sig
d1d0: 6e 61 6c 20 22 73 69 67 6e 75 6d 29 0a 20 20 28 nal "signum). (
d1e0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
d1f0: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
d200: 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 -port* "Received
d210: 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d signal " signum
d220: 20 22 20 61 61 61 20 65 78 69 74 69 6e 67 20 70 " aaa exiting p
d230: 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b 20 28 romptly"). ;; (
d240: 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 std-exit-procedu
d250: 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 re) ;; shouldn't
d260: 20 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 65 need this since
d270: 20 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 20 we are exiting
d280: 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 63 and it will be c
d290: 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 28 alled anyway. (
d2a0: 65 78 69 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 exit))..(define
d2b0: 28 73 70 65 63 69 61 6c 2d 73 69 67 6e 61 6c 2d (special-signal-
d2c0: 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a handler signum).
d2d0: 20 20 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 ;; (signal-mas
d2e0: 6b 21 20 73 69 67 6e 75 6d 29 0a 20 20 28 73 65 k! signum). (se
d2f0: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
d300: 2a 20 23 74 29 0a 20 20 3b 3b 28 64 65 62 75 67 * #t). ;;(debug
d310: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a :print-info 13 *
d320: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
d330: 2a 20 22 67 6f 74 20 73 69 67 6e 61 6c 20 22 73 * "got signal "s
d340: 69 67 6e 75 6d 29 0a 20 20 28 64 65 62 75 67 3a ignum). (debug:
d350: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
d360: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
d370: 20 22 52 65 63 65 69 76 65 64 20 73 69 67 6e 61 "Received signa
d380: 6c 20 22 20 73 69 67 6e 75 6d 20 22 20 73 65 6e l " signum " sen
d390: 64 69 6e 67 20 65 6d 61 69 6c 20 62 65 66 6f 72 ding email befor
d3a0: 20 65 78 69 74 69 6e 67 21 21 22 29 0a 20 20 3b exiting!!"). ;
d3b0: 3b 54 4f 44 4f 20 73 65 6e 64 20 65 6d 61 69 6c ;TODO send email
d3c0: 20 74 6f 20 6e 6f 74 69 66 79 20 61 64 6d 69 6e to notify admin
d3d0: 20 63 6f 6e 74 61 63 74 20 6c 69 73 74 65 64 20 contact listed
d3e0: 69 6e 20 74 68 65 20 63 6f 6e 66 69 67 20 74 68 in the config th
d3f0: 61 74 20 74 68 65 20 6c 69 73 6e 65 72 20 67 6f at the lisner go
d400: 74 20 6b 69 6c 6c 65 64 0a 20 20 3b 3b 20 28 73 t killed. ;; (s
d410: 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 td-exit-procedur
d420: 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 20 e) ;; shouldn't
d430: 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 65 20 need this since
d440: 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 20 61 we are exiting a
d450: 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 63 61 nd it will be ca
d460: 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 28 65 lled anyway. (e
d470: 78 69 74 29 29 0a 0a 0a 28 73 65 74 2d 73 69 67 xit))...(set-sig
d480: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
d490: 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 69 67 nal/int std-sig
d4a0: 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b nal-handler) ;;
d4b0: 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d ^C.(set-signal-
d4c0: 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f handler! signal/
d4d0: 74 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 6c 2d term std-signal-
d4e0: 68 61 6e 64 6c 65 72 29 0a 0a 3b 3b 20 28 73 65 handler)..;; (se
d4f0: 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 t-signal-handler
d500: 21 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 74 ! signal/stop st
d510: 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 d-signal-handler
d520: 29 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 ) ;; ^Z NO, do
d530: 4e 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a NOT handle ^Z!..
d540: 3b 3b 20 46 6f 72 63 65 20 61 20 6d 65 67 61 74 ;; Force a megat
d550: 65 73 74 20 63 6c 65 61 6e 75 70 2d 64 62 20 69 est cleanup-db i
d560: 66 20 76 65 72 73 69 6f 6e 20 69 73 20 63 68 61 f version is cha
d570: 6e 67 65 64 20 61 6e 64 20 73 6b 69 70 2d 76 65 nged and skip-ve
d580: 72 73 69 6f 6e 2d 63 68 65 63 6b 20 6e 6f 74 20 rsion-check not
d590: 73 70 65 63 69 66 69 65 64 0a 3b 3b 20 44 6f 20 specified.;; Do
d5a0: 4e 4f 54 20 63 68 65 63 6b 20 69 66 20 6e 6f 74 NOT check if not
d5b0: 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 21 0a 3b 3b on homehost!.;;
d5c0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
d5d0: 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 6f 6e :exit-on-version
d5e0: 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 69 66 20 -changed). (if
d5f0: 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 (common:on-homeh
d600: 6f 73 74 3f 29 0a 20 20 20 20 20 20 28 69 66 20 ost?). (if
d610: 28 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e (common:api-chan
d620: 67 65 64 3f 29 0a 09 20 20 28 6c 65 74 2a 20 28 ged?).. (let* (
d630: 28 6d 74 63 6f 6e 66 20 28 63 6f 6e 63 20 28 67 (mtconf (conc (g
d640: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
d650: 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f ariable "MT_RUN_
d660: 41 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f 6d 65 AREA_HOME") "/me
d670: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 gatest.config"))
d680: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d690: 20 28 64 62 66 69 6c 65 20 20 28 63 6f 6e 63 20 (dbfile (conc
d6a0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
d6b0: 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 -variable "MT_RU
d6c0: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f N_AREA_HOME") "/
d6d0: 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 0a 20 megatest.db")).
d6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d6f0: 72 65 61 64 2d 6f 6e 6c 79 20 28 6e 6f 74 20 28 read-only (not (
d700: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
d710: 73 3f 20 64 62 66 69 6c 65 29 29 29 0a 20 20 20 s? dbfile))).
d720: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
d730: 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 struct (db:setup
d740: 20 23 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 #t))).. (deb
d750: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
d760: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 ult-log-port*...
d770: 09 20 22 57 41 52 4e 49 4e 47 3a 20 56 65 72 73 . "WARNING: Vers
d780: 69 6f 6e 20 6d 69 73 6d 61 74 63 68 21 5c 6e 22 ion mismatch!\n"
d790: 0a 09 09 09 20 22 20 20 20 65 78 70 65 63 74 65 .... " expecte
d7a0: 64 3a 20 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 d: " (common:ver
d7b0: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 20 sion-signature)
d7c0: 22 5c 6e 22 0a 09 09 09 20 22 20 20 20 67 6f 74 "\n".... " got
d7d0: 3a 20 20 20 20 20 20 22 20 28 63 6f 6d 6d 6f 6e : " (common
d7e0: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
d7f0: 72 73 69 6f 6e 29 29 0a 20 20 20 20 20 20 20 20 rsion)).
d800: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
d810: 20 20 20 20 20 20 20 28 28 67 65 74 2d 65 6e 76 ((get-env
d820: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
d830: 65 20 22 4d 54 5f 53 4b 49 50 5f 44 42 5f 4d 49 e "MT_SKIP_DB_MI
d840: 47 52 41 54 45 22 29 20 23 74 29 0a 20 20 20 20 GRATE") #t).
d850: 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 ((and (
d860: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
d870: 74 73 3f 20 6d 74 63 6f 6e 66 29 20 28 63 6f 6d ts? mtconf) (com
d880: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
d890: 20 64 62 66 69 6c 65 29 20 28 6e 6f 74 20 72 65 dbfile) (not re
d8a0: 61 64 2d 6f 6e 6c 79 29 0a 20 20 20 20 20 20 20 ad-only).
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 71 3f (eq?
d8c0: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 (current-user-i
d8d0: 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 d)(file-owner mt
d8e0: 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 conf))) ;; safe
d8f0: 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d to run -cleanup-
d900: 64 62 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 db.
d910: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
d920: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
d930: 74 2a 20 22 20 20 20 49 20 73 65 65 20 79 6f 75 t* " I see you
d940: 20 61 72 65 20 74 68 65 20 6f 77 6e 65 72 20 6f are the owner o
d950: 66 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 f megatest.confi
d960: 67 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f g, attempting to
d970: 20 63 6c 65 61 6e 75 70 20 61 6e 64 20 72 65 73 cleanup and res
d980: 65 74 20 74 6f 20 6e 65 77 20 76 65 72 73 69 6f et to new versio
d990: 6e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 n").
d9a0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
d9b0: 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 ions.
d9c0: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 exn.
d9d0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
d9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d9f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
da00: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
da10: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 77 69 74 "Failed to swit
da20: 63 68 20 76 65 72 73 69 6f 6e 73 2e 22 29 0a 20 ch versions.").
da30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
da50: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
da60: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
da70: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
da80: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
da90: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
daa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
dab0: 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
dac0: 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
dad0: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 ror-port)).
dae0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
daf0: 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 1)).
db00: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 (common:cle
db10: 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 anup-db dbstruct
db20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
db30: 20 28 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 ((not (common:f
db40: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 6f ile-exists? mtco
db50: 6e 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nf)).
db60: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
db70: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
db80: 6f 72 74 2a 20 22 20 20 20 6d 65 67 61 74 65 73 ort* " megates
db90: 74 2e 63 6f 6e 66 69 67 20 64 6f 65 73 20 6e 6f t.config does no
dba0: 74 20 65 78 69 73 74 20 69 6e 20 74 68 69 73 20 t exist in this
dbb0: 61 72 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 area. Cannot pr
dbc0: 6f 63 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 oceed with megat
dbd0: 65 73 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 est version migr
dbe0: 61 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 ation.").
dbf0: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
dc00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 . ((
dc10: 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 not (common:file
dc20: 2d 65 78 69 73 74 73 3f 20 64 62 66 69 6c 65 29 -exists? dbfile)
dc30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
dc40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
dc50: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
dc60: 2a 20 22 20 20 20 6d 65 67 61 74 65 73 74 2e 64 * " megatest.d
dc70: 62 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 b does not exist
dc80: 20 69 6e 20 74 68 69 73 20 61 72 65 61 2e 20 20 in this area.
dc90: 43 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 20 77 Cannot proceed w
dca0: 69 74 68 20 6d 65 67 61 74 65 73 74 20 76 65 72 ith megatest ver
dcb0: 73 69 6f 6e 20 6d 69 67 72 61 74 69 6f 6e 2e 22 sion migration."
dcc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
dcd0: 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 20 20 (exit 1)).
dce0: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 65 71 ((not (eq
dcf0: 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d ? (current-user-
dd00: 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d id)(file-owner m
dd10: 74 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 20 20 tconf))).
dd20: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
dd30: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
dd40: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 59 6f 75 og-port* " You
dd50: 20 64 6f 20 6e 6f 74 20 6f 77 6e 20 6d 65 67 61 do not own mega
dd60: 74 65 73 74 2e 64 62 20 69 6e 20 74 68 69 73 20 test.db in this
dd70: 61 72 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 area. Cannot pr
dd80: 6f 63 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 oceed with megat
dd90: 65 73 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 est version migr
dda0: 61 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 ation.").
ddb0: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
ddc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 . (r
ddd0: 65 61 64 2d 6f 6e 6c 79 0a 20 20 20 20 20 20 20 ead-only.
dde0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
ddf0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
de00: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 59 6f 75 og-port* " You
de10: 20 68 61 76 65 20 72 65 61 64 2d 6f 6e 6c 79 20 have read-only
de20: 61 63 63 65 73 73 20 74 6f 20 74 68 69 73 20 61 access to this a
de30: 72 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f rea. Cannot pro
de40: 63 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 ceed with megate
de50: 73 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 st version migra
de60: 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 tion.").
de70: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a (exit 1)).
de80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
de90: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 se.
dea0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
deb0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
dec0: 74 2a 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 t* " to switch v
ded0: 65 72 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 ersions you can
dee0: 72 75 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 run: \"megatest
def0: 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a -cleanup-db\"").
df00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
df10: 78 69 74 20 31 29 29 29 29 29 29 29 0a 3b 3b 20 xit 1))))))).;;
df20: 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 09 28 (begin.;;.(
df30: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
df40: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
df50: 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 "ERROR: cannot
df60: 6d 69 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 migrate version
df70: 75 6e 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f unless on homeho
df80: 73 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 3b st. Exiting.").;
df90: 3b 09 28 65 78 69 74 20 31 29 29 29 29 0a 0a 3b ;.(exit 1))))..;
dfa0: 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 65 77 68 ; Move me elsewh
dfb0: 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 44 54 20 ere ....;; RADT
dfc0: 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 6d 65 65 => Why do we mee
dfd0: 64 20 74 68 65 20 76 65 72 73 69 6f 6e 20 63 68 d the version ch
dfe0: 65 63 6b 20 68 65 72 65 2c 20 74 68 69 73 20 69 eck here, this i
dff0: 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 20 69 66 s called only if
e000: 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d 61 0a 3b version misma.;
e010: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
e020: 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 20 64 62 73 n:cleanup-db dbs
e030: 74 72 75 63 74 20 23 21 6b 65 79 20 28 66 75 6c truct #!key (ful
e040: 6c 20 23 66 29 29 0a 20 20 28 61 70 70 6c 79 20 l #f)). (apply
e050: 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 db:multi-db-sync
e060: 20 0a 20 20 20 64 62 73 74 72 75 63 74 0a 20 20 . dbstruct.
e070: 20 27 73 63 68 65 6d 61 0a 20 20 20 3b 3b 20 27 'schema. ;; '
e080: 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 6c 6c new2old. 'kill
e090: 73 65 72 76 65 72 73 0a 20 20 20 27 61 64 6a 2d servers. 'adj-
e0a0: 74 61 72 67 65 74 0a 20 20 20 3b 3b 20 27 6f 6c target. ;; 'ol
e0b0: 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 6f 6c d2new. 'new2ol
e0c0: 64 0a 20 20 20 3b 3b 20 28 69 66 20 66 75 6c 6c d. ;; (if full
e0d0: 0a 20 20 20 20 20 20 20 27 28 64 65 6a 75 6e 6b . '(dejunk
e0e0: 29 0a 20 20 20 20 20 20 20 3b 3b 20 27 28 29 29 ). ;; '())
e0f0: 0a 20 20 20 20 20 20 20 29 0a 20 20 28 69 66 20 . ). (if
e100: 28 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e (common:api-chan
e110: 67 65 64 3f 29 0a 20 20 20 20 20 20 28 63 6f 6d ged?). (com
e120: 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e mon:set-last-run
e130: 2d 76 65 72 73 69 6f 6e 29 29 29 0a 0a 29 0a 09 -version)))..)..
e140: 0a .