0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 srfi-1 posix re
01f0: 67 65 78 2d 63 61 73 65 20 62 61 73 65 36 34 20 gex-case base64
0200: 66 6f 72 6d 61 74 20 64 6f 74 2d 6c 6f 63 6b 69 format dot-locki
0210: 6e 67 20 63 73 76 2d 78 6d 6c 20 7a 33 20 73 71 ng csv-xml z3 sq
0220: 6c 2d 64 65 2d 6c 69 74 65 20 68 6f 73 74 69 6e l-de-lite hostin
0230: 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 fo md5 message-d
0240: 69 67 65 73 74 20 74 79 70 65 64 2d 72 65 63 6f igest typed-reco
0250: 72 64 73 20 64 69 72 65 63 74 6f 72 79 2d 75 74 rds directory-ut
0260: 69 6c 73 20 73 74 61 63 6b 0a 20 20 20 20 20 6d ils stack. m
0270: 61 74 63 68 61 62 6c 65 20 72 65 67 65 78 20 70 atchable regex p
0280: 6f 73 69 78 20 73 72 66 69 2d 31 38 20 65 78 74 osix srfi-18 ext
0290: 72 61 73 0a 20 20 20 20 20 70 6b 74 73 20 28 70 ras. pkts (p
02a0: 72 65 66 69 78 20 64 62 69 20 64 62 69 3a 29 29 refix dbi dbi:))
02b0: 0a 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 ..(import (prefi
02c0: 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 x sqlite3 sqlite
02d0: 33 3a 29 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 3:)).(import (pr
02e0: 65 66 69 78 20 62 61 73 65 36 34 20 62 61 73 65 efix base64 base
02f0: 36 34 3a 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 64:))..(declare
0300: 28 75 6e 69 74 20 63 6f 6d 6d 6f 6e 29 29 0a 0a (unit common))..
0310: 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e (include "common
0320: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a _records.scm")..
0330: 3b 3b 20 28 72 65 71 75 69 72 65 2d 6c 69 62 72 ;; (require-libr
0340: 61 72 79 20 6d 61 72 67 73 29 0a 3b 3b 20 28 69 ary margs).;; (i
0350: 6e 63 6c 75 64 65 20 22 6d 61 72 67 73 2e 73 63 nclude "margs.sc
0360: 6d 22 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 m")..;; (define
0370: 6f 6c 64 2d 65 78 69 74 20 65 78 69 74 29 0a 3b old-exit exit).;
0380: 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 65 ; .;; (define (e
0390: 78 69 74 20 2e 20 63 6f 64 65 29 0a 3b 3b 20 20 xit . code).;;
03a0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6f 64 65 (if (null? code
03b0: 29 0a 3b 3b 20 20 20 20 20 20 20 28 6f 6c 64 2d ).;; (old-
03c0: 65 78 69 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 exit).;; (
03d0: 6f 6c 64 2d 65 78 69 74 20 63 6f 64 65 29 29 29 old-exit code)))
03e0: 0a 0a 28 64 65 66 69 6e 65 20 67 65 74 65 6e 76 ..(define getenv
03f0: 20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 get-environment
0400: 2d 76 61 72 69 61 62 6c 65 29 0a 28 64 65 66 69 -variable).(defi
0410: 6e 65 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 ne (safe-setenv
0420: 6b 65 79 20 76 61 6c 29 0a 20 20 28 69 66 20 28 key val). (if (
0430: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
0440: 22 3a 22 20 6b 65 79 29 20 3b 3b 20 76 61 72 69 ":" key) ;; vari
0450: 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 6e 67 ables containing
0460: 20 3a 20 61 72 65 20 66 6f 72 20 69 6e 74 65 72 : are for inter
0470: 6e 61 6c 20 75 73 65 20 61 6e 64 20 63 61 6e 6e nal use and cann
0480: 6f 74 20 62 65 20 65 6e 76 69 72 6f 6e 6d 65 6e ot be environmen
0490: 74 20 76 61 72 69 61 62 6c 65 73 2e 0a 20 20 20 t variables..
04a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
04b0: 65 72 72 6f 72 20 34 20 2a 64 65 66 61 75 6c 74 error 4 *default
04c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6b 69 70 -log-port* "skip
04d0: 20 73 65 74 74 69 6e 67 20 69 6e 74 65 72 6e 61 setting interna
04e0: 6c 20 75 73 65 20 6f 6e 6c 79 20 76 61 72 69 61 l use only varia
04f0: 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 6e 67 20 bles containing
0500: 5c 22 3a 5c 22 22 29 0a 20 20 20 20 20 20 28 69 \":\""). (i
0510: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 f (and (string?
0520: 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 73 74 val).. (st
0530: 72 69 6e 67 3f 20 6b 65 79 29 29 0a 09 20 20 28 ring? key)).. (
0540: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
0550: 73 0a 09 20 20 20 20 20 20 65 78 6e 0a 09 20 20 s.. exn..
0560: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0570: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
0580: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 t-log-port* "bad
0590: 20 76 61 6c 75 65 20 66 6f 72 20 73 65 74 65 6e value for seten
05a0: 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c 20 v, key=" key ",
05b0: 76 61 6c 75 65 3d 22 20 76 61 6c 29 0a 09 20 20 value=" val)..
05c0: 20 20 28 73 65 74 65 6e 76 20 6b 65 79 20 76 61 (setenv key va
05d0: 6c 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 l)).. (debug:pr
05e0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
05f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0600: 62 61 64 20 76 61 6c 75 65 20 66 6f 72 20 73 65 bad value for se
0610: 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 tenv, key=" key
0620: 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 6c 29 29 ", value=" val))
0630: 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 6f 6d 65 ))..(define home
0640: 20 28 67 65 74 65 6e 76 20 22 48 4f 4d 45 22 29 (getenv "HOME")
0650: 29 0a 28 64 65 66 69 6e 65 20 75 73 65 72 20 28 ).(define user (
0660: 67 65 74 65 6e 76 20 22 55 53 45 52 22 29 29 0a getenv "USER")).
0670: 0a 3b 3b 20 47 4c 4f 42 41 4c 53 0a 0a 3b 3b 20 .;; GLOBALS..;;
0680: 43 4f 4e 54 45 58 54 53 0a 28 64 65 66 73 74 72 CONTEXTS.(defstr
0690: 75 63 74 20 63 78 74 0a 20 20 28 74 61 73 6b 64 uct cxt. (taskd
06a0: 62 20 23 66 29 0a 20 20 28 63 6d 75 74 65 78 20 b #f). (cmutex
06b0: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 29 0a 3b (make-mutex))).;
06c0: 3b 20 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 ; (define *conte
06d0: 78 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d xts* (make-hash-
06e0: 74 61 62 6c 65 29 29 0a 3b 3b 20 28 64 65 66 69 table)).;; (defi
06f0: 6e 65 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 ne *context-mute
0700: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
0710: 0a 0a 3b 3b 20 3b 3b 20 73 61 66 65 20 6d 65 74 ..;; ;; safe met
0720: 68 6f 64 20 66 6f 72 20 61 63 63 65 73 73 69 6e hod for accessin
0730: 67 20 61 20 63 6f 6e 74 65 78 74 20 67 69 76 65 g a context give
0740: 6e 20 61 20 74 6f 70 70 61 74 68 0a 3b 3b 20 3b n a toppath.;; ;
0750: 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f ;.;; (define (co
0760: 6d 6d 6f 6e 3a 77 69 74 68 2d 63 78 74 20 74 6f mmon:with-cxt to
0770: 70 70 61 74 68 20 70 72 6f 63 29 0a 3b 3b 20 20 ppath proc).;;
0780: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 63 (mutex-lock! *c
0790: 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 29 0a 3b ontext-mutex*).;
07a0: 3b 20 20 20 28 6c 65 74 20 28 28 63 78 74 20 28 ; (let ((cxt (
07b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
07c0: 65 66 61 75 6c 74 20 2a 63 6f 6e 74 65 78 74 73 efault *contexts
07d0: 2a 20 74 6f 70 70 61 74 68 20 23 66 29 29 29 0a * toppath #f))).
07e0: 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ;; (if (not
07f0: 63 78 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 cxt).;;
0800: 28 73 65 74 21 20 63 78 74 20 28 6c 65 74 20 28 (set! cxt (let (
0810: 28 78 20 28 6d 61 6b 65 2d 63 78 74 29 29 29 28 (x (make-cxt)))(
0820: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
0830: 2a 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 *contexts* toppa
0840: 74 68 20 78 29 20 78 29 29 29 0a 3b 3b 20 20 20 th x) x))).;;
0850: 20 20 28 6c 65 74 20 28 28 63 78 74 2d 6d 75 74 (let ((cxt-mut
0860: 65 78 20 28 63 78 74 2d 6d 75 74 65 78 20 63 78 ex (cxt-mutex cx
0870: 74 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 6d t))).;; (m
0880: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 63 6f utex-unlock! *co
0890: 6e 74 65 78 74 2d 6d 75 74 65 78 2a 29 0a 3b 3b ntext-mutex*).;;
08a0: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f (mutex-lo
08b0: 63 6b 21 20 63 78 74 2d 6d 75 74 65 78 29 0a 3b ck! cxt-mutex).;
08c0: 3b 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 ; (let ((r
08d0: 65 73 20 28 70 72 6f 63 20 63 78 74 29 29 29 0a es (proc cxt))).
08e0: 3b 3b 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 ;; (mute
08f0: 78 2d 75 6e 6c 6f 63 6b 21 20 63 78 74 2d 6d 75 x-unlock! cxt-mu
0900: 74 65 78 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 tex).;;
0910: 72 65 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 res)))).
0920: 0a 3b 3b 20 41 20 68 61 73 68 20 74 61 62 6c 65 .;; A hash table
0930: 20 74 68 61 74 20 63 61 6e 20 62 65 20 61 63 63 that can be acc
0940: 65 73 73 65 64 20 62 79 20 23 7b 73 63 68 65 6d essed by #{schem
0950: 65 20 2e 2e 2e 7d 20 63 61 6c 6c 73 20 69 6e 0a e ...} calls in.
0960: 3b 3b 20 63 6f 6e 66 69 67 20 66 69 6c 65 73 2e ;; config files.
0970: 20 41 6c 6c 6f 77 73 20 63 6f 6d 6d 75 6e 69 63 Allows communic
0980: 61 74 69 6e 67 20 62 65 74 77 65 65 6e 20 63 6f ating between co
0990: 6e 66 67 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 nfgs.;;.(define
09a0: 2a 75 73 65 72 2d 68 61 73 68 2d 64 61 74 61 2a *user-hash-data*
09b0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
09c0: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 64 62 e))..(define *db
09d0: 2d 6b 65 79 73 2a 20 23 66 29 0a 0a 28 64 65 66 -keys* #f)..(def
09e0: 69 6e 65 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a ine *configinfo*
09f0: 20 20 20 23 66 29 20 20 20 3b 3b 20 72 61 77 20 #f) ;; raw
0a00: 72 65 73 75 6c 74 73 20 66 72 6f 6d 20 73 65 74 results from set
0a10: 75 70 2c 20 69 6e 63 6c 75 64 65 73 20 74 6f 70 up, includes top
0a20: 70 61 74 68 20 61 6e 64 20 74 61 62 6c 65 20 66 path and table f
0a30: 72 6f 6d 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e rom megatest.con
0a40: 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e fig.(define *run
0a50: 63 6f 6e 66 69 67 64 61 74 2a 20 23 66 29 20 20 configdat* #f)
0a60: 20 3b 3b 20 72 75 6e 20 63 6f 6e 66 69 67 73 20 ;; run configs
0a70: 64 61 74 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f data.(define *co
0a80: 6e 66 69 67 64 61 74 2a 20 20 20 20 23 66 29 20 nfigdat* #f)
0a90: 20 20 3b 3b 20 6d 65 67 61 74 65 73 74 2e 63 6f ;; megatest.co
0aa0: 6e 66 69 67 20 64 61 74 61 0a 28 64 65 66 69 6e nfig data.(defin
0ab0: 65 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a e *configstatus*
0ac0: 20 23 66 29 20 20 20 3b 3b 20 73 74 61 74 75 73 #f) ;; status
0ad0: 20 6f 66 20 64 61 74 61 3b 20 27 66 75 6c 6c 64 of data; 'fulld
0ae0: 61 74 61 20 3a 20 61 6c 6c 20 70 72 6f 63 65 73 ata : all proces
0af0: 73 69 6e 67 20 64 6f 6e 65 2c 20 23 66 20 3a 20 sing done, #f :
0b00: 6e 6f 20 64 61 74 61 20 79 65 74 2c 20 27 70 61 no data yet, 'pa
0b10: 72 74 69 61 6c 64 61 74 61 20 3a 20 70 61 72 74 rtialdata : part
0b20: 69 61 6c 20 72 65 61 64 20 64 6f 6e 65 0a 28 64 ial read done.(d
0b30: 65 66 69 6e 65 20 2a 74 6f 70 70 61 74 68 2a 20 efine *toppath*
0b40: 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 #f).(define
0b50: 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 *already-seen-r
0b60: 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 23 unconfig-info* #
0b70: 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 f)..(define *tes
0b80: 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 t-meta-updated*
0b90: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0ba0: 29 29 0a 28 64 65 66 69 6e 65 20 2a 67 6c 6f 62 )).(define *glob
0bb0: 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 20 30 alexitstatus* 0
0bc0: 29 20 3b 3b 20 61 74 74 65 6d 70 74 20 74 6f 20 ) ;; attempt to
0bd0: 77 6f 72 6b 20 61 72 6f 75 6e 64 20 70 6f 73 73 work around poss
0be0: 69 62 6c 65 20 74 68 72 65 61 64 20 69 73 73 75 ible thread issu
0bf0: 65 73 0a 28 64 65 66 69 6e 65 20 2a 70 61 73 73 es.(define *pass
0c00: 6e 75 6d 2a 20 20 20 20 20 20 20 20 20 20 20 30 num* 0
0c10: 29 20 3b 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e ) ;; when runnin
0c20: 67 20 74 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f g track calls to
0c30: 20 72 75 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 run-tests or si
0c40: 6d 69 6c 61 72 0a 3b 3b 20 28 64 65 66 69 6e 65 milar.;; (define
0c50: 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 20 *alt-log-file*
0c60: 23 66 29 20 20 3b 3b 20 75 73 65 64 20 62 79 20 #f) ;; used by
0c70: 2d 6c 6f 67 0a 28 64 65 66 69 6e 65 20 2a 63 6f -log.(define *co
0c80: 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 20 20 mmon:denoise*
0c90: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0ca0: 65 29 29 20 3b 3b 20 66 6f 72 20 6c 6f 77 20 6e e)) ;; for low n
0cb0: 6f 69 73 65 20 70 72 69 6e 74 69 6e 67 0a 28 64 oise printing.(d
0cc0: 65 66 69 6e 65 20 2a 64 65 66 61 75 6c 74 2d 6c efine *default-l
0cd0: 6f 67 2d 70 6f 72 74 2a 20 20 28 63 75 72 72 65 og-port* (curre
0ce0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
0cf0: 28 64 65 66 69 6e 65 20 2a 74 69 6d 65 2d 7a 65 (define *time-ze
0d00: 72 6f 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ro* (current-sec
0d10: 6f 6e 64 73 29 29 20 3b 3b 20 66 6f 72 20 74 68 onds)) ;; for th
0d20: 65 20 77 61 74 63 68 64 6f 67 0a 0a 3b 3b 20 44 e watchdog..;; D
0d30: 41 54 41 42 41 53 45 0a 28 64 65 66 69 6e 65 20 ATABASE.(define
0d40: 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 20 20 *dbstruct-db*
0d50: 20 20 20 20 20 20 23 66 29 20 3b 3b 20 75 73 65 #f) ;; use
0d60: 64 20 74 6f 20 63 61 63 68 65 20 74 68 65 20 64 d to cache the d
0d70: 62 73 74 72 75 63 74 20 69 6e 20 64 62 3a 73 65 bstruct in db:se
0d80: 74 75 70 2e 20 47 6f 61 6c 20 69 73 20 74 6f 20 tup. Goal is to
0d90: 72 65 6d 6f 76 65 20 74 68 69 73 2e 0a 3b 3b 20 remove this..;;
0da0: 64 62 20 73 74 61 74 73 0a 28 64 65 66 69 6e 65 db stats.(define
0db0: 20 2a 64 62 2d 73 74 61 74 73 2a 20 20 20 20 20 *db-stats*
0dc0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
0dd0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 61 73 h-table)) ;; has
0de0: 68 20 6f 66 20 76 65 63 74 6f 72 73 20 3c 20 63 h of vectors < c
0df0: 6f 75 6e 74 20 64 75 72 61 74 69 6f 6e 2d 74 6f ount duration-to
0e00: 74 61 6c 20 3e 0a 28 64 65 66 69 6e 65 20 2a 64 tal >.(define *d
0e10: 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 20 20 b-stats-mutex*
0e20: 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 (make-mutex)
0e30: 29 0a 3b 3b 20 64 62 20 61 63 63 65 73 73 0a 28 ).;; db access.(
0e40: 64 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d define *db-last-
0e50: 61 63 63 65 73 73 2a 20 20 20 20 20 20 28 63 75 access* (cu
0e60: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
0e70: 3b 3b 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 ;; last db acces
0e80: 73 2c 20 75 73 65 64 20 69 6e 20 73 65 72 76 65 s, used in serve
0e90: 72 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 72 r.(define *db-wr
0ea0: 69 74 65 2d 61 63 63 65 73 73 2a 20 20 20 20 20 ite-access*
0eb0: 23 74 29 0a 3b 3b 20 64 62 20 73 79 6e 63 0a 28 #t).;; db sync.(
0ec0: 64 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d define *db-last-
0ed0: 73 79 6e 63 2a 20 20 20 20 20 20 20 20 30 29 20 sync* 0)
0ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ef0: 3b 3b 20 6c 61 73 74 20 74 69 6d 65 20 74 68 65 ;; last time the
0f00: 20 73 79 6e 63 20 74 6f 20 6d 65 67 61 74 65 73 sync to megates
0f10: 74 2e 64 62 20 68 61 70 70 65 6e 65 64 0a 28 64 t.db happened.(d
0f20: 65 66 69 6e 65 20 2a 64 62 2d 73 79 6e 63 2d 69 efine *db-sync-i
0f30: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 20 n-progress* #f)
0f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0f50: 3b 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 ; if there is a
0f60: 73 79 6e 63 20 69 6e 20 70 72 6f 67 72 65 73 73 sync in progress
0f70: 20 64 6f 20 6e 6f 74 20 74 72 79 20 74 6f 20 73 do not try to s
0f80: 74 61 72 74 20 61 6e 6f 74 68 65 72 0a 28 64 65 tart another.(de
0f90: 66 69 6e 65 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 fine *db-multi-s
0fa0: 79 6e 63 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 ync-mutex* (make
0fb0: 2d 6d 75 74 65 78 29 29 20 20 20 20 20 20 3b 3b -mutex)) ;;
0fc0: 20 70 72 6f 74 65 63 74 20 61 63 63 65 73 73 20 protect access
0fd0: 74 6f 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 to *db-sync-in-p
0fe0: 72 6f 67 72 65 73 73 2a 2c 20 2a 64 62 2d 6c 61 rogress*, *db-la
0ff0: 73 74 2d 73 79 6e 63 2a 0a 3b 3b 20 74 61 73 6b st-sync*.;; task
1000: 20 64 62 0a 28 64 65 66 69 6e 65 20 2a 74 61 73 db.(define *tas
1010: 6b 2d 64 62 2a 20 20 20 20 20 20 20 20 20 20 20 k-db*
1020: 20 20 23 66 29 20 3b 3b 20 28 76 65 63 74 6f 72 #f) ;; (vector
1030: 20 64 62 20 70 61 74 68 2d 74 6f 2d 64 62 29 0a db path-to-db).
1040: 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 (define *db-acce
1050: 73 73 2d 61 6c 6c 6f 77 65 64 2a 20 20 20 23 74 ss-allowed* #t
1060: 29 20 3b 3b 20 66 6c 61 67 20 74 6f 20 61 6c 6c ) ;; flag to all
1070: 6f 77 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e ow access.(defin
1080: 65 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 e *db-access-mut
1090: 65 78 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 ex* (make-mu
10a0: 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 tex)).(define *d
10b0: 62 2d 74 72 61 6e 73 61 63 74 69 6f 6e 2d 6d 75 b-transaction-mu
10c0: 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 tex* (make-mutex
10d0: 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 63 )).(define *db-c
10e0: 61 63 68 65 2d 70 61 74 68 2a 20 20 20 20 20 20 ache-path*
10f0: 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 #f).(define *db
1100: 2d 77 69 74 68 2d 64 62 2d 6d 75 74 65 78 2a 20 -with-db-mutex*
1110: 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 (make-mutex))
1120: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 70 69 .(define *db-api
1130: 2d 63 61 6c 6c 2d 74 69 6d 65 2a 20 20 20 20 28 -call-time* (
1140: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
1150: 29 20 3b 3b 20 68 61 73 68 20 6f 66 20 63 6f 6d ) ;; hash of com
1160: 6d 61 6e 64 20 3d 3e 20 28 6c 69 73 74 20 6f 66 mand => (list of
1170: 20 74 69 6d 65 73 29 0a 3b 3b 20 6e 6f 20 73 79 times).;; no sy
1180: 6e 63 20 64 62 0a 28 64 65 66 69 6e 65 20 2a 6e nc db.(define *n
1190: 6f 2d 73 79 6e 63 2d 64 62 2a 20 20 20 20 20 20 o-sync-db*
11a0: 20 20 20 20 23 66 29 0a 0a 3b 3b 20 53 45 52 56 #f)..;; SERV
11b0: 45 52 0a 28 64 65 66 69 6e 65 20 2a 6d 79 2d 63 ER.(define *my-c
11c0: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
11d0: 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 74 72 #f).(define *tr
11e0: 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 20 20 ansport-type*
11f0: 20 27 68 74 74 70 29 20 20 20 20 20 20 20 20 20 'http)
1200: 20 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 20 ;; override
1210: 77 69 74 68 20 5b 73 65 72 76 65 72 5d 20 74 72 with [server] tr
1220: 61 6e 73 70 6f 72 74 20 68 74 74 70 7c 72 70 63 ansport http|rpc
1230: 7c 6e 6d 73 67 0a 28 64 65 66 69 6e 65 20 2a 72 |nmsg.(define *r
1240: 75 6e 72 65 6d 6f 74 65 2a 20 20 20 20 20 20 20 unremote*
1250: 20 20 23 66 29 20 20 20 20 20 20 20 20 20 20 20 #f)
1260: 20 20 20 20 20 3b 3b 20 69 66 20 73 65 74 20 75 ;; if set u
1270: 70 20 66 6f 72 20 73 65 72 76 65 72 20 63 6f 6d p for server com
1280: 6d 75 6e 69 63 61 74 69 6f 6e 20 74 68 69 73 20 munication this
1290: 77 69 6c 6c 20 68 6f 6c 64 20 3c 68 6f 73 74 20 will hold <host
12a0: 70 6f 72 74 3e 0a 3b 3b 20 28 64 65 66 69 6e 65 port>.;; (define
12b0: 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 *max-cache-size
12c0: 2a 20 20 20 20 30 29 0a 28 64 65 66 69 6e 65 20 * 0).(define
12d0: 2a 6c 6f 67 67 65 64 2d 69 6e 2d 63 6c 69 65 6e *logged-in-clien
12e0: 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ts* (make-hash-t
12f0: 61 62 6c 65 29 29 0a 3b 3b 20 28 64 65 66 69 6e able)).;; (defin
1300: 65 20 2a 73 65 72 76 65 72 2d 69 64 2a 20 20 20 e *server-id*
1310: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
1320: 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 e *server-info*
1330: 20 20 20 20 20 20 23 66 29 20 20 3b 3b 20 67 6f #f) ;; go
1340: 6f 64 20 63 61 6e 64 69 64 61 74 65 20 66 6f 72 od candidate for
1350: 20 65 61 73 69 6c 79 20 63 6f 6e 76 65 72 74 20 easily convert
1360: 74 6f 20 6e 6f 6e 2d 67 6c 6f 62 61 6c 0a 28 64 to non-global.(d
1370: 65 66 69 6e 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 efine *time-to-e
1380: 78 69 74 2a 20 20 20 20 20 20 23 66 29 0a 28 64 xit* #f).(d
1390: 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 72 75 efine *server-ru
13a0: 6e 2a 20 20 20 20 20 20 20 20 23 74 29 0a 28 64 n* #t).(d
13b0: 65 66 69 6e 65 20 2a 72 75 6e 2d 69 64 2a 20 20 efine *run-id*
13c0: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 #f).(d
13d0: 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 6b 69 efine *server-ki
13e0: 6e 64 2d 72 75 6e 2a 20 20 20 28 6d 61 6b 65 2d nd-run* (make-
13f0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 hash-table)).(de
1400: 66 69 6e 65 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a fine *home-host*
1410: 20 20 20 20 20 20 20 20 20 23 66 29 0a 3b 3b 20 #f).;;
1420: 28 64 65 66 69 6e 65 20 2a 74 6f 74 61 6c 2d 6e (define *total-n
1430: 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 on-write-delay*
1440: 30 29 0a 28 64 65 66 69 6e 65 20 2a 68 65 61 72 0).(define *hear
1450: 74 62 65 61 74 2d 6d 75 74 65 78 2a 20 20 20 28 tbeat-mutex* (
1460: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
1470: 66 69 6e 65 20 2a 61 70 69 2d 70 72 6f 63 65 73 fine *api-proces
1480: 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a s-request-count*
1490: 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 0).(define *max
14a0: 2d 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 -api-process-req
14b0: 75 65 73 74 73 2a 20 30 29 0a 28 64 65 66 69 6e uests* 0).(defin
14c0: 65 20 2a 73 65 72 76 65 72 2d 6f 76 65 72 6c 6f e *server-overlo
14d0: 61 64 65 64 2a 20 20 23 66 29 0a 0a 3b 3b 20 63 aded* #f)..;; c
14e0: 6c 69 65 6e 74 0a 28 64 65 66 69 6e 65 20 2a 72 lient.(define *r
14f0: 6d 74 2d 6d 75 74 65 78 2a 20 20 20 20 20 20 20 mt-mutex*
1500: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 (make-mutex))
1510: 20 20 20 20 3b 3b 20 72 65 6d 6f 74 65 20 61 63 ;; remote ac
1520: 63 65 73 73 20 63 61 6c 6c 73 20 6d 75 74 65 78 cess calls mutex
1530: 20 0a 0a 3b 3b 20 52 50 43 20 74 72 61 6e 73 70 ..;; RPC transp
1540: 6f 72 74 0a 28 64 65 66 69 6e 65 20 2a 72 70 63 ort.(define *rpc
1550: 3a 6c 69 73 74 65 6e 65 72 2a 20 20 20 20 20 20 :listener*
1560: 23 66 29 0a 0a 3b 3b 20 4b 45 59 20 69 6e 66 6f #f)..;; KEY info
1570: 0a 28 64 65 66 69 6e 65 20 2a 74 61 72 67 65 74 .(define *target
1580: 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 * (ma
1590: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
15a0: 3b 3b 20 63 61 63 68 65 20 74 68 65 20 74 61 72 ;; cache the tar
15b0: 67 65 74 20 68 65 72 65 3b 20 74 61 72 67 65 74 get here; target
15c0: 20 69 73 20 6b 65 79 76 61 6c 31 2f 6b 65 79 76 is keyval1/keyv
15d0: 61 6c 32 2f 2e 2e 2e 2f 6b 65 79 76 61 6c 4e 0a al2/.../keyvalN.
15e0: 28 64 65 66 69 6e 65 20 2a 6b 65 79 73 2a 20 20 (define *keys*
15f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1600: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1610: 3b 20 63 61 63 68 65 20 74 68 65 20 6b 65 79 73 ; cache the keys
1620: 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 6b here.(define *k
1630: 65 79 76 61 6c 73 2a 20 20 20 20 20 20 20 20 20 eyvals*
1640: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
1650: 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 74 6f le)).(define *to
1660: 70 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 ptest-paths*
1670: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1680: 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 6f 70 e)) ;; cache top
1690: 74 65 73 74 20 70 61 74 68 20 73 65 74 74 69 6e test path settin
16a0: 67 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 gs here.(define
16b0: 2a 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 *test-paths*
16c0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
16d0: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
16e0: 74 65 73 74 2d 69 64 20 74 6f 20 74 65 73 74 20 test-id to test
16f0: 72 75 6e 20 70 61 74 68 73 20 68 65 72 65 0a 28 run paths here.(
1700: 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 69 64 73 define *test-ids
1710: 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 * (make
1720: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
1730: 20 63 61 63 68 65 20 72 75 6e 2d 69 64 2c 20 74 cache run-id, t
1740: 65 73 74 6e 61 6d 65 2c 20 61 6e 64 20 69 74 65 estname, and ite
1750: 6d 2d 70 61 74 68 20 3d 3e 20 74 65 73 74 2d 69 m-path => test-i
1760: 64 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d d.(define *test-
1770: 69 6e 66 6f 2a 20 20 20 20 20 20 20 20 20 28 6d info* (m
1780: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1790: 20 3b 3b 20 63 61 63 68 65 20 74 68 65 20 74 65 ;; cache the te
17a0: 73 74 20 69 6e 66 6f 20 72 65 63 6f 72 64 73 2c st info records,
17b0: 20 75 70 64 61 74 65 20 74 68 65 20 73 74 61 74 update the stat
17c0: 65 2c 20 73 74 61 74 75 73 2c 20 72 75 6e 5f 64 e, status, run_d
17d0: 75 72 61 74 69 6f 6e 20 65 74 63 2e 20 66 72 6f uration etc. fro
17e0: 6d 20 74 65 73 74 64 61 74 2e 64 62 0a 0a 28 64 m testdat.db..(d
17f0: 65 66 69 6e 65 20 2a 72 75 6e 2d 69 6e 66 6f 2d efine *run-info-
1800: 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 cache* (make
1810: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
1820: 20 72 75 6e 20 69 6e 66 6f 20 69 73 20 73 74 61 run info is sta
1830: 62 6c 65 2c 20 6e 6f 20 6e 65 65 64 20 74 6f 20 ble, no need to
1840: 72 65 67 65 74 0a 28 64 65 66 69 6e 65 20 2a 6c reget.(define *l
1850: 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 65 aunch-setup-mute
1860: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
1870: 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 ;; need to
1880: 62 65 20 61 62 6c 65 20 74 6f 20 63 61 6c 6c 20 be able to call
1890: 6c 61 75 6e 63 68 3a 73 65 74 75 70 20 6f 66 74 launch:setup oft
18a0: 65 6e 20 73 6f 20 6d 75 74 65 78 20 69 74 20 61 en so mutex it a
18b0: 6e 64 20 72 65 2d 63 61 6c 6c 20 74 68 65 20 72 nd re-call the r
18c0: 65 61 6c 20 64 65 61 6c 20 6f 6e 6c 79 20 69 66 eal deal only if
18d0: 20 2a 74 6f 70 70 61 74 68 2a 20 6e 6f 74 20 73 *toppath* not s
18e0: 65 74 0a 28 64 65 66 69 6e 65 20 2a 68 6f 6d 65 et.(define *home
18f0: 68 6f 73 74 2d 6d 75 74 65 78 2a 20 20 20 20 20 host-mutex*
1900: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b (make-mutex))..;
1910: 3b 20 4d 69 73 63 65 6c 6c 61 6e 65 6f 75 73 0a ; Miscellaneous.
1920: 28 64 65 66 69 6e 65 20 2a 74 72 69 67 67 65 72 (define *trigger
1930: 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 6d 61 s-mutex* (ma
1940: 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b ke-mutex)) ;
1950: 3b 20 62 6c 6f 63 6b 20 6f 76 65 72 6c 61 70 70 ; block overlapp
1960: 69 6e 67 20 70 72 6f 63 65 73 73 69 6e 67 20 6f ing processing o
1970: 66 20 74 72 69 67 67 65 72 73 0a 0a 28 64 65 66 f triggers..(def
1980: 73 74 72 75 63 74 20 72 65 6d 6f 74 65 0a 20 20 struct remote.
1990: 28 68 68 2d 64 61 74 20 20 20 20 20 20 20 20 20 (hh-dat
19a0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 (common:get-h
19b0: 6f 6d 65 68 6f 73 74 29 29 20 3b 3b 20 68 6f 6d omehost)) ;; hom
19c0: 65 68 6f 73 74 20 72 65 63 6f 72 64 20 28 20 61 ehost record ( a
19d0: 64 64 72 20 2e 20 68 68 66 6c 61 67 20 29 0a 20 ddr . hhflag ).
19e0: 20 28 73 65 72 76 65 72 2d 75 72 6c 20 20 20 20 (server-url
19f0: 20 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 (if *toppath
1a00: 2a 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d * (server:check-
1a10: 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 if-running *topp
1a20: 61 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 ath*))) ;; (serv
1a30: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
1a40: 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 20 23 ing *toppath*) #
1a50: 66 29 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 f)). (last-serv
1a60: 65 72 2d 63 68 65 63 6b 20 30 29 20 20 3b 3b 20 er-check 0) ;;
1a70: 6c 61 73 74 20 74 69 6d 65 20 77 65 20 63 68 65 last time we che
1a80: 63 6b 65 64 20 74 6f 20 73 65 65 20 69 66 20 74 cked to see if t
1a90: 68 65 20 73 65 72 76 65 72 20 77 61 73 20 61 6c he server was al
1aa0: 69 76 65 0a 20 20 28 63 6f 6e 6e 64 61 74 20 20 ive. (conndat
1ab0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 #f). (
1ac0: 74 72 61 6e 73 70 6f 72 74 20 20 20 20 20 20 20 transport
1ad0: 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 *transport-typ
1ae0: 65 2a 29 0a 20 20 28 73 65 72 76 65 72 2d 74 69 e*). (server-ti
1af0: 6d 65 6f 75 74 20 20 20 20 28 73 65 72 76 65 72 meout (server
1b00: 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 29 20 3b :get-timeout)) ;
1b10: 3b 20 64 65 66 61 75 6c 74 20 66 72 6f 6d 20 73 ; default from s
1b20: 65 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 erver:get-timeou
1b30: 74 0a 20 20 28 66 6f 72 63 65 2d 73 65 72 76 65 t. (force-serve
1b40: 72 20 20 20 20 20 20 23 66 29 0a 20 20 28 72 6f r #f). (ro
1b50: 2d 6d 6f 64 65 20 20 20 20 20 20 20 20 20 20 20 -mode
1b60: 23 66 29 20 20 0a 20 20 28 72 6f 2d 6d 6f 64 65 #f) . (ro-mode
1b70: 2d 63 68 65 63 6b 65 64 20 20 20 23 66 29 29 20 -checked #f))
1b80: 3b 3b 20 66 6c 61 67 20 74 68 61 74 20 69 6e 64 ;; flag that ind
1b90: 69 63 61 74 65 73 20 77 65 20 68 61 76 65 20 63 icates we have c
1ba0: 68 65 63 6b 65 64 20 66 6f 72 20 72 6f 2d 6d 6f hecked for ro-mo
1bb0: 64 65 0a 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 de..;; launching
1bc0: 20 61 6e 64 20 68 6f 73 74 73 0a 28 64 65 66 73 and hosts.(defs
1bd0: 74 72 75 63 74 20 68 6f 73 74 0a 20 20 28 72 65 truct host. (re
1be0: 61 63 68 61 62 6c 65 20 20 20 20 23 66 29 0a 20 achable #f).
1bf0: 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 20 30 (last-update 0
1c00: 29 0a 20 20 28 6c 61 73 74 2d 75 73 65 64 20 20 ). (last-used
1c10: 20 20 30 29 0a 20 20 28 6c 61 73 74 2d 63 70 75 0). (last-cpu
1c20: 6c 6f 61 64 20 31 29 29 0a 0a 28 64 65 66 69 6e load 1))..(defin
1c30: 65 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 e *host-loads*
1c40: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
1c50: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 h-table))..;; ca
1c60: 63 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 che environment
1c70: 76 61 72 73 20 66 6f 72 20 65 61 63 68 20 72 75 vars for each ru
1c80: 6e 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a n here.(define *
1c90: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
1ca0: 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 id* (make-hash-t
1cb0: 61 62 6c 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 able))..;; Testc
1cc0: 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e onfig and runcon
1cd0: 66 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 fig caches. .(de
1ce0: 66 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 fine *testconfig
1cf0: 73 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d s* (make-
1d00: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1d10: 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 test-name => tes
1d20: 74 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 tconfig.(define
1d30: 2a 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 *runconfigs*
1d40: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1d50: 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 table)) ;; targe
1d60: 74 20 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 t => runconfi
1d70: 67 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 g..;; This is a
1d80: 63 61 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 cache of pre-req
1d90: 73 20 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d s met, don't re-
1da0: 63 61 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 calc in cases wh
1db0: 65 72 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 ere called with
1dc0: 73 61 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 same params less
1dd0: 20 74 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 than.;; five se
1de0: 63 6f 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e conds ago.(defin
1df0: 65 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d e *pre-reqs-met-
1e00: 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 cache* (make-has
1e10: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 h-table))..;; ca
1e20: 63 68 65 20 6f 66 20 76 65 72 62 6f 73 69 74 79 che of verbosity
1e30: 20 67 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b given string.;;
1e40: 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 .(define *verbos
1e50: 69 74 79 2d 63 61 63 68 65 2a 20 20 20 20 28 6d ity-cache* (m
1e60: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1e70: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
1e80: 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 0a n:clear-caches).
1e90: 20 20 28 73 65 74 21 20 2a 74 61 72 67 65 74 2a (set! *target*
1ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
1eb0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1ec0: 20 20 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 (set! *keys*
1ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
1ee0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1ef0: 20 20 28 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 (set! *keyvals
1f00: 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 * (ma
1f10: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1f20: 20 20 28 73 65 74 21 20 2a 74 6f 70 74 65 73 74 (set! *toptest
1f30: 2d 70 61 74 68 73 2a 20 20 20 20 20 20 28 6d 61 -paths* (ma
1f40: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1f50: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 70 61 (set! *test-pa
1f60: 74 68 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 ths* (ma
1f70: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1f80: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 (set! *test-id
1f90: 73 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 s* (ma
1fa0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1fb0: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 6e (set! *test-in
1fc0: 66 6f 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 fo* (ma
1fd0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1fe0: 20 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 (set! *run-inf
1ff0: 6f 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 o-cache* (ma
2000: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
2010: 20 20 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 (set! *env-var
2020: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 s-by-run-id* (ma
2030: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
2040: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 (set! *test-id
2050: 2d 63 61 63 68 65 2a 20 20 20 20 20 20 28 6d 61 -cache* (ma
2060: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
2070: 0a 0a 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 72 ..;; Generic str
2080: 69 6e 67 20 64 61 74 61 62 61 73 65 0a 28 64 65 ing database.(de
2090: 66 69 6e 65 20 73 64 62 3a 71 72 79 20 23 66 29 fine sdb:qry #f)
20a0: 20 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 ;; (make-sdb:qr
20b0: 79 29 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 y)) ;; 'init #f
20c0: 29 0a 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 74 ).;; Generic pat
20d0: 68 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 h database.(defi
20e0: 6e 65 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 ne *fdb* #f)..(d
20f0: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e efine *last-laun
2100: 63 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ch* (current-sec
2110: 6f 6e 64 73 29 29 20 3b 3b 20 75 73 65 20 66 6f onds)) ;; use fo
2120: 72 20 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 r throttling the
2130: 20 6c 61 75 6e 63 68 20 72 61 74 65 2e 20 57 6f launch rate. Wo
2140: 75 6c 64 20 62 65 20 62 65 74 74 65 72 20 74 6f uld be better to
2150: 20 75 73 65 20 74 68 65 20 64 62 20 61 6e 64 20 use the db and
2160: 6c 61 73 74 20 74 69 6d 65 20 6f 66 20 61 20 74 last time of a t
2170: 65 73 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 est in LAUNCHED
2180: 73 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d state...;;======
2190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21d0: 0a 3b 3b 20 56 20 45 20 52 20 53 20 49 20 4f 20 .;; V E R S I O
21e0: 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N.;;============
21f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
2230: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
2240: 66 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 full-version).
2250: 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 (conc megatest-v
2260: 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 ersion "-" megat
2270: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 est-fossil-hash)
2280: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
2290: 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 on:version-signa
22a0: 74 75 72 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 ture). (conc me
22b0: 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 gatest-version "
22c0: 2d 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 65 -" (substring me
22d0: 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 gatest-fossil-ha
22e0: 73 68 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 sh 0 4)))..;; fr
22f0: 6f 6d 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 om metadat looku
2300: 70 20 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 p MEGATEST_VERSI
2310: 4f 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ON.;;.(define (c
2320: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
2330: 75 6e 2d 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 un-version) ;; R
2340: 41 44 54 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 ADT => How does
2350: 74 68 69 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e this work in sen
2360: 64 2d 72 65 63 65 69 76 65 20 66 75 6e 63 74 69 d-receive functi
2370: 6f 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 on??; assume it
2380: 69 73 20 74 68 65 20 76 61 6c 75 65 20 73 61 76 is the value sav
2390: 65 64 20 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 ed in some DB.
23a0: 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 (rmt:get-var "ME
23b0: 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 GATEST_VERSION")
23c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
23d0: 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d on:get-last-run-
23e0: 76 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a version-number).
23f0: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
2400: 72 20 0a 20 20 20 28 73 75 62 73 74 72 69 6e 67 r . (substring
2410: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
2420: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 t-run-version) 0
2430: 20 36 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6)))..(define (
2440: 63 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d common:set-last-
2450: 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 run-version). (
2460: 72 6d 74 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 rmt:set-var "MEG
2470: 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 ATEST_VERSION" (
2480: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 common:version-s
2490: 69 67 6e 61 74 75 72 65 29 29 29 0a 0a 3b 3b 20 ignature)))..;;
24a0: 70 6f 73 74 69 76 65 20 6e 75 6d 62 65 72 20 69 postive number i
24b0: 66 20 6d 65 67 61 74 65 73 74 20 76 65 72 73 69 f megatest versi
24c0: 6f 6e 20 3e 20 64 62 20 76 65 72 73 69 6f 6e 0a on > db version.
24d0: 3b 3b 20 6e 65 67 61 74 69 76 65 20 6e 75 6d 62 ;; negative numb
24e0: 65 72 20 69 66 20 6d 65 67 61 74 65 73 74 20 76 er if megatest v
24f0: 65 72 73 69 6f 6e 20 3c 20 64 62 20 76 65 72 73 ersion < db vers
2500: 69 6f 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ion.(define (com
2510: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 64 62 2d 64 mon:version-db-d
2520: 65 6c 74 61 29 0a 20 20 20 20 20 20 20 20 20 28 elta). (
2530: 2d 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 - megatest-versi
2540: 6f 6e 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c on (common:get-l
2550: 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 2d ast-run-version-
2560: 6e 75 6d 62 65 72 29 29 29 0a 0a 28 64 65 66 69 number)))..(defi
2570: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 ne (common:versi
2580: 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 on-changed?). (
2590: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6d not (equal? (com
25a0: 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e mon:get-last-run
25b0: 2d 76 65 72 73 69 6f 6e 29 0a 20 20 20 20 20 20 -version).
25c0: 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
25d0: 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 :version-signatu
25e0: 72 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 re))))..(define
25f0: 28 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e (common:api-chan
2600: 67 65 64 3f 29 0a 20 20 28 6e 6f 74 20 28 65 71 ged?). (not (eq
2610: 75 61 6c 3f 20 28 73 75 62 73 74 72 69 6e 67 20 ual? (substring
2620: 28 2d 3e 73 74 72 69 6e 67 20 6d 65 67 61 74 65 (->string megate
2630: 73 74 2d 76 65 72 73 69 6f 6e 29 20 30 20 34 29 st-version) 0 4)
2640: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2650: 28 73 75 62 73 74 72 69 6e 67 20 28 63 6f 6e 63 (substring (conc
2660: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
2670: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 29 20 t-run-version))
2680: 30 20 34 29 29 29 29 0a 20 20 0a 3b 3b 20 4d 6f 0 4)))). .;; Mo
2690: 76 65 20 6d 65 20 65 6c 73 65 77 68 65 72 65 20 ve me elsewhere
26a0: 2e 2e 2e 0a 3b 3b 20 52 41 44 54 20 3d 3e 20 57 ....;; RADT => W
26b0: 68 79 20 64 6f 20 77 65 20 6d 65 65 64 20 74 68 hy do we meed th
26c0: 65 20 76 65 72 73 69 6f 6e 20 63 68 65 63 6b 20 e version check
26d0: 68 65 72 65 2c 20 74 68 69 73 20 69 73 20 63 61 here, this is ca
26e0: 6c 6c 65 64 20 6f 6e 6c 79 20 69 66 20 76 65 72 lled only if ver
26f0: 73 69 6f 6e 20 6d 69 73 6d 61 0a 3b 3b 0a 28 64 sion misma.;;.(d
2700: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c efine (common:cl
2710: 65 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 63 eanup-db dbstruc
2720: 74 20 23 21 6b 65 79 20 28 66 75 6c 6c 20 23 66 t #!key (full #f
2730: 29 29 0a 20 20 28 61 70 70 6c 79 20 64 62 3a 6d )). (apply db:m
2740: 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 20 ulti-db-sync .
2750: 20 64 62 73 74 72 75 63 74 0a 20 20 20 27 73 63 dbstruct. 'sc
2760: 68 65 6d 61 0a 20 20 20 3b 3b 20 27 6e 65 77 32 hema. ;; 'new2
2770: 6f 6c 64 0a 20 20 20 27 6b 69 6c 6c 73 65 72 76 old. 'killserv
2780: 65 72 73 0a 20 20 20 27 61 64 6a 2d 74 61 72 67 ers. 'adj-targ
2790: 65 74 0a 20 20 20 3b 3b 20 27 6f 6c 64 32 6e 65 et. ;; 'old2ne
27a0: 77 0a 20 20 20 27 6e 65 77 32 6f 6c 64 0a 20 20 w. 'new2old.
27b0: 20 28 69 66 20 66 75 6c 6c 0a 20 20 20 20 20 20 (if full.
27c0: 20 27 28 64 65 6a 75 6e 6b 29 0a 20 20 20 20 20 '(dejunk).
27d0: 20 20 27 28 29 29 29 0a 20 20 28 69 66 20 28 63 '())). (if (c
27e0: 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 65 ommon:api-change
27f0: 64 3f 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f d?). (commo
2800: 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:set-last-run-v
2810: 65 72 73 69 6f 6e 29 29 29 0a 0a 3b 3b 20 52 6f ersion)))..;; Ro
2820: 74 61 74 65 20 6c 6f 67 73 2c 20 6c 6f 67 69 63 tate logs, logic
2830: 3a 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 : .;;
2840: 20 20 20 20 20 20 69 66 20 3e 20 35 30 30 6b 20 if > 500k
2850: 61 6e 64 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 and older than 1
2860: 20 77 65 65 6b 3a 0a 3b 3b 20 20 20 20 20 20 20 week:.;;
2870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
2880: 6d 6f 76 65 20 70 72 65 76 69 6f 75 73 20 63 6f move previous co
2890: 6d 70 72 65 73 73 65 64 20 6c 6f 67 20 61 6e 64 mpressed log and
28a0: 20 63 6f 6d 70 72 65 73 73 20 74 68 69 73 20 6c compress this l
28b0: 6f 67 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 og.;; WARNING: T
28c0: 68 69 73 20 70 72 6f 63 20 6f 70 65 72 61 74 65 his proc operate
28d0: 73 20 61 73 73 75 6d 69 6e 67 20 74 68 61 74 20 s assuming that
28e0: 69 74 20 69 73 20 69 6e 20 74 68 65 20 64 69 72 it is in the dir
28f0: 65 63 74 6f 72 79 20 61 62 6f 76 65 20 74 68 65 ectory above the
2900: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 6c 6f 67 .;; log
2910: 73 20 64 69 72 65 63 74 6f 72 79 20 79 6f 75 20 s directory you
2920: 77 69 73 68 20 74 6f 20 6c 6f 67 2d 72 6f 74 61 wish to log-rota
2930: 74 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 te..;;.(define (
2940: 63 6f 6d 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f common:rotate-lo
2950: 67 73 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 gs). (if (not (
2960: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
2970: 3f 20 22 6c 6f 67 73 22 29 29 28 63 72 65 61 74 ? "logs"))(creat
2980: 65 2d 64 69 72 65 63 74 6f 72 79 20 22 6c 6f 67 e-directory "log
2990: 73 22 29 29 0a 20 20 28 64 69 72 65 63 74 6f 72 s")). (director
29a0: 79 2d 66 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 y-fold . (lamb
29b0: 64 61 20 28 66 69 6c 65 20 72 65 6d 29 0a 20 20 da (file rem).
29c0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
29d0: 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a tions. exn.
29e0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
29f0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
2a00: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 lt-log-port* "fa
2a10: 69 6c 65 64 20 74 6f 20 72 6f 74 61 74 65 20 6c iled to rotate l
2a20: 6f 67 20 22 20 66 69 6c 65 20 22 2c 20 70 72 6f og " file ", pro
2a30: 62 61 62 6c 79 20 68 61 6e 64 6c 65 64 20 62 79 bably handled by
2a40: 20 61 6e 6f 74 68 65 72 20 70 72 6f 63 65 73 73 another process
2a50: 2e 22 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 ."). (let*
2a60: 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 ((fullname (conc
2a70: 20 22 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 0a "logs/" file)).
2a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
2a90: 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 72 65 le-age (- (curre
2aa0: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 nt-seconds)(file
2ab0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
2ac0: 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 29 29 29 0a me fullname)))).
2ad0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 (if (or
2ae0: 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d 61 74 (and (string-mat
2af0: 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 20 66 69 6c ch "^.*.log" fil
2b00: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
2b10: 20 20 20 20 20 20 20 20 28 3e 20 28 66 69 6c 65 (> (file
2b20: 2d 73 69 7a 65 20 66 75 6c 6c 6e 61 6d 65 29 20 -size fullname)
2b30: 32 30 30 30 30 30 29 29 0a 20 20 20 20 20 20 20 200000)).
2b40: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 73 (and (s
2b50: 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 73 65 tring-match "^se
2b60: 72 76 65 72 2d 2e 2a 2e 6c 6f 67 22 20 66 69 6c rver-.*.log" fil
2b70: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
2b80: 20 20 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 (> (- (c
2b90: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
2ba0: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
2bb0: 6f 6e 2d 74 69 6d 65 20 66 75 6c 6c 6e 61 6d 65 on-time fullname
2bc0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2bd0: 20 20 20 20 20 20 20 20 20 20 20 28 2a 20 38 20 (* 8
2be0: 36 30 20 36 30 29 29 29 29 0a 20 20 20 20 20 20 60 60)))).
2bf0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 67 7a 66 (let ((gzf
2c00: 69 6c 65 20 28 63 6f 6e 63 20 66 75 6c 6c 6e 61 ile (conc fullna
2c10: 6d 65 20 22 2e 67 7a 22 29 29 29 0a 20 20 20 20 me ".gz"))).
2c20: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 63 (if (c
2c30: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
2c40: 73 3f 20 67 7a 66 69 6c 65 29 0a 20 20 20 20 20 s? gzfile).
2c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
2c60: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
2c70: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
2c80: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
2c90: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2ca0: 72 65 6d 6f 76 69 6e 67 20 22 20 67 7a 66 69 6c removing " gzfil
2cb0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
2cc0: 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 (delete-f
2cd0: 69 6c 65 20 67 7a 66 69 6c 65 29 29 29 0a 20 20 ile gzfile))).
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
2cf0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
2d00: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2d10: 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 6e 67 20 t* "compressing
2d20: 22 20 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 " file).
2d30: 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 (system (c
2d40: 6f 6e 63 20 22 67 7a 69 70 20 22 20 66 75 6c 6c onc "gzip " full
2d50: 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 name))).
2d60: 20 20 20 20 28 69 66 20 28 3e 20 66 69 6c 65 2d (if (> file-
2d70: 61 67 65 20 28 2a 20 28 73 74 72 69 6e 67 2d 3e age (* (string->
2d80: 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 number (or (conf
2d90: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
2da0: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
2db0: 6c 6f 67 2d 65 78 70 69 72 65 2d 64 61 79 73 22 log-expire-days"
2dc0: 29 20 22 33 30 22 29 29 20 32 34 20 33 36 30 30 ) "30")) 24 3600
2dd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2de0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
2df0: 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 tions.
2e00: 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 exn.
2e10: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 #f.
2e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e30: 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 66 75 6c (delete-file ful
2e40: 6c 6e 61 6d 65 29 29 29 29 29 29 29 0a 20 20 20 lname))))))).
2e50: 27 28 29 0a 20 20 20 22 6c 6f 67 73 22 29 29 0a '(). "logs")).
2e60: 0a 3b 3b 20 46 6f 72 63 65 20 61 20 6d 65 67 61 .;; Force a mega
2e70: 74 65 73 74 20 63 6c 65 61 6e 75 70 2d 64 62 20 test cleanup-db
2e80: 69 66 20 76 65 72 73 69 6f 6e 20 69 73 20 63 68 if version is ch
2e90: 61 6e 67 65 64 20 61 6e 64 20 73 6b 69 70 2d 76 anged and skip-v
2ea0: 65 72 73 69 6f 6e 2d 63 68 65 63 6b 20 6e 6f 74 ersion-check not
2eb0: 20 73 70 65 63 69 66 69 65 64 0a 3b 3b 20 44 6f specified.;; Do
2ec0: 20 4e 4f 54 20 63 68 65 63 6b 20 69 66 20 6e 6f NOT check if no
2ed0: 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 21 0a 3b t on homehost!.;
2ee0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2ef0: 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 6f n:exit-on-versio
2f00: 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 69 66 n-changed). (if
2f10: 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 (common:on-home
2f20: 68 6f 73 74 3f 29 0a 20 20 20 20 20 20 28 69 66 host?). (if
2f30: 20 28 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 (common:api-cha
2f40: 6e 67 65 64 3f 29 0a 09 20 20 28 6c 65 74 2a 20 nged?).. (let*
2f50: 28 28 6d 74 63 6f 6e 66 20 28 63 6f 6e 63 20 28 ((mtconf (conc (
2f60: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
2f70: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e variable "MT_RUN
2f80: 5f 41 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f 6d _AREA_HOME") "/m
2f90: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 egatest.config")
2fa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2fb0: 20 20 28 64 62 66 69 6c 65 20 28 63 6f 6e 63 20 (dbfile (conc
2fc0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
2fd0: 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 -variable "MT_RU
2fe0: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f N_AREA_HOME") "/
2ff0: 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 0a 20 megatest.db")).
3000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3010: 72 65 61 64 2d 6f 6e 6c 79 20 28 6e 6f 74 20 28 read-only (not (
3020: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
3030: 73 3f 20 64 62 66 69 6c 65 29 29 29 0a 20 20 20 s? dbfile))).
3040: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
3050: 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 struct (db:setup
3060: 20 23 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 #t))).. (deb
3070: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3080: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 ult-log-port*...
3090: 09 20 22 57 41 52 4e 49 4e 47 3a 20 56 65 72 73 . "WARNING: Vers
30a0: 69 6f 6e 20 6d 69 73 6d 61 74 63 68 21 5c 6e 22 ion mismatch!\n"
30b0: 0a 09 09 09 20 22 20 20 20 65 78 70 65 63 74 65 .... " expecte
30c0: 64 3a 20 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 d: " (common:ver
30d0: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 20 sion-signature)
30e0: 22 5c 6e 22 0a 09 09 09 20 22 20 20 20 67 6f 74 "\n".... " got
30f0: 3a 20 20 20 20 20 20 22 20 28 63 6f 6d 6d 6f 6e : " (common
3100: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
3110: 72 73 69 6f 6e 29 29 0a 20 20 20 20 20 20 20 20 rsion)).
3120: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
3130: 20 20 20 20 20 20 20 28 28 67 65 74 2d 65 6e 76 ((get-env
3140: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
3150: 65 20 22 4d 54 5f 53 4b 49 50 5f 44 42 5f 4d 49 e "MT_SKIP_DB_MI
3160: 47 52 41 54 45 22 29 20 23 74 29 0a 20 20 20 20 GRATE") #t).
3170: 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 ((and (
3180: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
3190: 74 73 3f 20 6d 74 63 6f 6e 66 29 20 28 63 6f 6d ts? mtconf) (com
31a0: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
31b0: 20 64 62 66 69 6c 65 29 20 28 6e 6f 74 20 72 65 dbfile) (not re
31c0: 61 64 2d 6f 6e 6c 79 29 0a 20 20 20 20 20 20 20 ad-only).
31d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 71 3f (eq?
31e0: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 (current-user-i
31f0: 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 d)(file-owner mt
3200: 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 conf))) ;; safe
3210: 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d to run -cleanup-
3220: 64 62 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 db.
3230: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3240: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3250: 74 2a 20 22 20 20 20 49 20 73 65 65 20 79 6f 75 t* " I see you
3260: 20 61 72 65 20 74 68 65 20 6f 77 6e 65 72 20 6f are the owner o
3270: 66 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 f megatest.confi
3280: 67 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f g, attempting to
3290: 20 63 6c 65 61 6e 75 70 20 61 6e 64 20 72 65 73 cleanup and res
32a0: 65 74 20 74 6f 20 6e 65 77 20 76 65 72 73 69 6f et to new versio
32b0: 6e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 n").
32c0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
32d0: 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 ions.
32e0: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 exn.
32f0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
3300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3310: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3320: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3330: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 77 69 74 "Failed to swit
3340: 63 68 20 76 65 72 73 69 6f 6e 73 2e 22 29 0a 20 ch versions.").
3350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3360: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
3370: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3380: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
3390: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
33a0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
33b0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
33c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
33d0: 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
33e0: 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
33f0: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 ror-port)).
3400: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
3410: 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 1)).
3420: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 (common:cle
3430: 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 anup-db dbstruct
3440: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
3450: 20 28 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 ((not (common:f
3460: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 6f ile-exists? mtco
3470: 6e 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 nf)).
3480: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3490: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
34a0: 6f 72 74 2a 20 22 20 20 20 6d 65 67 61 74 65 73 ort* " megates
34b0: 74 2e 63 6f 6e 66 69 67 20 64 6f 65 73 20 6e 6f t.config does no
34c0: 74 20 65 78 69 73 74 20 69 6e 20 74 68 69 73 20 t exist in this
34d0: 61 72 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 area. Cannot pr
34e0: 6f 63 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 oceed with megat
34f0: 65 73 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 est version migr
3500: 61 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 ation.").
3510: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
3520: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 . ((
3530: 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 not (common:file
3540: 2d 65 78 69 73 74 73 3f 20 64 62 66 69 6c 65 29 -exists? dbfile)
3550: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3560: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
3570: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3580: 2a 20 22 20 20 20 6d 65 67 61 74 65 73 74 2e 64 * " megatest.d
3590: 62 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 b does not exist
35a0: 20 69 6e 20 74 68 69 73 20 61 72 65 61 2e 20 20 in this area.
35b0: 43 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 20 77 Cannot proceed w
35c0: 69 74 68 20 6d 65 67 61 74 65 73 74 20 76 65 72 ith megatest ver
35d0: 73 69 6f 6e 20 6d 69 67 72 61 74 69 6f 6e 2e 22 sion migration."
35e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
35f0: 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 20 20 (exit 1)).
3600: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 65 71 ((not (eq
3610: 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d ? (current-user-
3620: 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d id)(file-owner m
3630: 74 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 20 20 tconf))).
3640: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
3650: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
3660: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 59 6f 75 og-port* " You
3670: 20 64 6f 20 6e 6f 74 20 6f 77 6e 20 6d 65 67 61 do not own mega
3680: 74 65 73 74 2e 64 62 20 69 6e 20 74 68 69 73 20 test.db in this
3690: 61 72 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 area. Cannot pr
36a0: 6f 63 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 oceed with megat
36b0: 65 73 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 est version migr
36c0: 61 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 ation.").
36d0: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
36e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 . (r
36f0: 65 61 64 2d 6f 6e 6c 79 0a 20 20 20 20 20 20 20 ead-only.
3700: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
3710: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
3720: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 59 6f 75 og-port* " You
3730: 20 68 61 76 65 20 72 65 61 64 2d 6f 6e 6c 79 20 have read-only
3740: 61 63 63 65 73 73 20 74 6f 20 74 68 69 73 20 61 access to this a
3750: 72 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f rea. Cannot pro
3760: 63 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 ceed with megate
3770: 73 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 st version migra
3780: 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 tion.").
3790: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a (exit 1)).
37a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
37b0: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 se.
37c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
37d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
37e0: 74 2a 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 t* " to switch v
37f0: 65 72 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 ersions you can
3800: 72 75 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 run: \"megatest
3810: 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a -cleanup-db\"").
3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
3830: 78 69 74 20 31 29 29 29 29 29 29 29 0a 3b 3b 20 xit 1))))))).;;
3840: 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 09 28 (begin.;;.(
3850: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3860: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3870: 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 "ERROR: cannot
3880: 6d 69 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 migrate version
3890: 75 6e 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f unless on homeho
38a0: 73 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 3b st. Exiting.").;
38b0: 3b 09 28 65 78 69 74 20 31 29 29 29 29 0a 0a 3b ;.(exit 1))))..;
38c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
38d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
38e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
38f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3900: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 20 41 =======.;; S P A
3910: 20 52 20 53 20 45 20 20 20 41 20 52 20 52 20 41 R S E A R R A
3920: 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d Y S.;;=========
3930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
3970: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 70 61 define (make-spa
3980: 72 73 65 2d 61 72 72 61 79 29 0a 20 20 28 6c 65 rse-array). (le
3990: 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 70 61 72 t ((a (make-spar
39a0: 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 20 20 20 se-vector))).
39b0: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
39c0: 73 65 74 21 20 61 20 30 20 28 6d 61 6b 65 2d 73 set! a 0 (make-s
39d0: 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 0a 20 parse-vector)).
39e0: 20 20 20 61 29 29 0a 0a 28 64 65 66 69 6e 65 20 a))..(define
39f0: 28 73 70 61 72 73 65 2d 61 72 72 61 79 3f 20 61 (sparse-array? a
3a00: 29 0a 20 20 28 61 6e 64 20 28 73 70 61 72 73 65 ). (and (sparse
3a10: 2d 76 65 63 74 6f 72 3f 20 61 29 0a 20 20 20 20 -vector? a).
3a20: 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f (sparse-vecto
3a30: 72 3f 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f r? (sparse-vecto
3a40: 72 2d 72 65 66 20 61 20 30 29 29 29 29 0a 0a 28 r-ref a 0))))..(
3a50: 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 define (sparse-a
3a60: 72 72 61 79 2d 72 65 66 20 61 20 78 20 79 29 0a rray-ref a x y).
3a70: 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 (let ((row (sp
3a80: 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 arse-vector-ref
3a90: 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 a x))). (if r
3aa0: 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 ow..(sparse-vect
3ab0: 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 0a 09 23 or-ref row y)..#
3ac0: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
3ad0: 70 61 72 73 65 2d 61 72 72 61 79 2d 73 65 74 21 parse-array-set!
3ae0: 20 61 20 78 20 79 20 76 61 6c 29 0a 20 20 28 6c a x y val). (l
3af0: 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 73 65 et ((row (sparse
3b00: 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 78 29 -vector-ref a x)
3b10: 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 0a 09 )). (if row..
3b20: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 (sparse-vector-s
3b30: 65 74 21 20 72 6f 77 20 79 20 76 61 6c 29 0a 09 et! row y val)..
3b40: 28 6c 65 74 20 28 28 6e 65 77 2d 72 6f 77 20 28 (let ((new-row (
3b50: 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 make-sparse-vect
3b60: 6f 72 29 29 29 0a 09 20 20 28 73 70 61 72 73 65 or))).. (sparse
3b70: 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 61 20 78 -vector-set! a x
3b80: 20 6e 65 77 2d 72 6f 77 29 0a 09 20 20 28 73 70 new-row).. (sp
3b90: 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 arse-vector-set!
3ba0: 20 6e 65 77 2d 72 6f 77 20 79 20 76 61 6c 29 29 new-row y val))
3bb0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
3bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
3c00: 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 20 L O C K E R S
3c10: 20 41 20 4e 20 44 20 20 20 42 20 4c 20 4f 20 43 A N D B L O C
3c20: 20 4b 20 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d 3d K E R S .;;====
3c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c70: 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 72 ==..;; block fur
3c80: 74 68 65 72 20 61 63 63 65 73 73 65 73 20 74 6f ther accesses to
3c90: 20 64 61 74 61 62 61 73 65 73 2e 20 43 61 6c 6c databases. Call
3ca0: 20 74 68 69 73 20 62 65 66 6f 72 65 20 73 68 75 this before shu
3cb0: 74 74 69 6e 67 20 64 62 20 64 6f 77 6e 0a 28 64 tting db down.(d
3cc0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 efine (common:db
3cd0: 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 65 72 2d 71 -block-further-q
3ce0: 75 65 72 69 65 73 29 0a 20 20 28 6d 75 74 65 78 ueries). (mutex
3cf0: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 -lock! *db-acces
3d00: 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 74 s-mutex*). (set
3d10: 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c ! *db-access-all
3d20: 6f 77 65 64 2a 20 23 66 29 0a 20 20 28 6d 75 74 owed* #f). (mut
3d30: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 ex-unlock! *db-a
3d40: 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 29 0a 0a ccess-mutex*))..
3d50: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3d60: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
3d70: 64 3f 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c d?). (let ((val
3d80: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
3d90: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
3da0: 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a -access-mutex*).
3db0: 09 20 20 20 20 20 20 20 2a 64 62 2d 61 63 63 65 . *db-acce
3dc0: 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 20 ss-allowed*..
3dd0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
3de0: 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 k! *db-access-mu
3df0: 74 65 78 2a 29 29 29 29 0a 20 20 20 20 76 61 6c tex*)))). val
3e00: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
3e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
3e50: 55 20 53 20 45 20 46 20 55 20 4c 20 20 20 53 20 U S E F U L S
3e60: 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d T U F F.;;======
3e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3eb0: 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 74 68 69 ..;; convert thi
3ec0: 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 73 74 20 ngs to an alist
3ed0: 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 2c 20 23 or assoc list, #
3ee0: 66 20 67 65 74 73 20 63 6f 6e 76 65 72 74 65 64 f gets converted
3ef0: 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 66 69 6e to "".;;.(defin
3f00: 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 e (common:to-ali
3f10: 73 74 20 64 61 74 29 0a 20 20 28 63 6f 6e 64 0a st dat). (cond.
3f20: 20 20 20 28 28 6c 69 73 74 3f 20 64 61 74 29 20 ((list? dat)
3f30: 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f (map common:to
3f40: 2d 61 6c 69 73 74 20 64 61 74 29 29 0a 20 20 20 -alist dat)).
3f50: 28 28 76 65 63 74 6f 72 3f 20 64 61 74 29 0a 20 ((vector? dat).
3f60: 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 (map common:t
3f70: 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 6f 72 2d o-alist (vector-
3f80: 3e 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 20 >list dat))).
3f90: 28 28 70 61 69 72 3f 20 64 61 74 29 0a 20 20 20 ((pair? dat).
3fa0: 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f 6e 3a 74 (cons (common:t
3fb0: 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 64 61 74 o-alist (car dat
3fc0: 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 74 6f )).. (common:to
3fd0: 2d 61 6c 69 73 74 20 28 63 64 72 20 64 61 74 29 -alist (cdr dat)
3fe0: 29 29 29 0a 20 20 20 28 28 68 61 73 68 2d 74 61 ))). ((hash-ta
3ff0: 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 20 28 6d ble? dat). (m
4000: 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 ap common:to-ali
4010: 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e st (hash-table->
4020: 61 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 20 alist dat))).
4030: 28 65 6c 73 65 0a 20 20 20 20 28 69 66 20 64 61 (else. (if da
4040: 74 0a 09 64 61 74 0a 09 22 22 29 29 29 29 0a 0a t..dat..""))))..
4050: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
4060: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
4070: 77 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 0a waitval . keys).
4080: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 (let* ((key
4090: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
40a0: 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 sperse (map conc
40b0: 20 6b 65 79 73 29 20 22 2d 22 20 29 29 0a 09 20 keys) "-" ))..
40c0: 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d (lasttime (hash-
40d0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
40e0: 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 t *common:denois
40f0: 65 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 63 75 e* key 0)).. (cu
4100: 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d rrtime (current-
4110: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 seconds))). (
4120: 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 6d if (> (- currtim
4130: 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 74 e lasttime) wait
4140: 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 val)..(begin..
4150: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
4160: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
4170: 2a 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a * key currtime).
4180: 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 . #t)..#f)))..(
4190: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
41a0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 et-megatest-exe)
41b0: 0a 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 . (or (getenv "
41c0: 4d 54 5f 4d 45 47 41 54 45 53 54 22 29 20 22 6d MT_MEGATEST") "m
41d0: 65 67 61 74 65 73 74 22 29 29 0a 0a 28 64 65 66 egatest"))..(def
41e0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 ine (common:read
41f0: 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 -encoded-string
4200: 69 6e 73 74 72 29 0a 20 20 28 68 61 6e 64 6c 65 instr). (handle
4210: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
4220: 78 6e 0a 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 xn. (handle-ex
4230: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 65 78 6e ceptions. exn
4240: 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 . (begin.
4250: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
4260: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
4270: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 65 69 log-port* "recei
4280: 76 65 64 20 62 61 64 20 65 6e 63 6f 64 65 64 20 ved bad encoded
4290: 73 74 72 69 6e 67 20 5c 22 22 20 69 6e 73 74 72 string \"" instr
42a0: 20 22 5c 22 2c 20 6d 65 73 73 61 67 65 3a 20 22 "\", message: "
42b0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
42c0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
42d0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
42e0: 6e 29 29 0a 20 20 20 20 20 20 28 70 72 69 6e 74 n)). (print
42f0: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
4300: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
4310: 29 0a 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 ). #f).
4320: 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 (read (open-inpu
4330: 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 34 t-string (base64
4340: 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 :base64-decode i
4350: 6e 73 74 72 29 29 29 29 0a 20 20 20 28 72 65 61 nstr)))). (rea
4360: 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 d (open-input-st
4370: 72 69 6e 67 20 28 7a 33 3a 64 65 63 6f 64 65 2d ring (z3:decode-
4380: 62 75 66 66 65 72 20 28 62 61 73 65 36 34 3a 62 buffer (base64:b
4390: 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 ase64-decode ins
43a0: 74 72 29 29 29 29 29 29 0a 0a 3b 3b 20 64 6f 74 tr))))))..;; dot
43b0: 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 65 -locking egg see
43c0: 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 ms not to work,
43d0: 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 20 6e using this for n
43e0: 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 ow.;; if lock is
43f0: 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 70 69 older than expi
4400: 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 6d re-time then rem
4410: 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 20 61 ove it and try a
4420: 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 gain.;; to get t
4430: 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 he lock.;;.(defi
4440: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ne (common:simpl
4450: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d e-file-lock fnam
4460: 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d e #!key (expire-
4470: 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 68 61 time 300)). (ha
4480: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
4490: 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 exn.
44a0: 23 66 20 3b 3b 20 64 6f 6e 27 74 20 72 65 61 6c #f ;; don't real
44b0: 6c 79 20 63 61 72 65 20 77 68 61 74 20 77 65 6e ly care what wen
44c0: 74 20 77 72 6f 6e 67 20 72 69 67 68 74 20 6e 6f t wrong right no
44d0: 77 2e 20 4e 4f 54 45 3a 20 49 20 68 61 76 65 20 w. NOTE: I have
44e0: 6e 6f 74 20 73 65 65 6e 20 74 68 69 73 20 6f 6e not seen this on
44f0: 65 20 61 63 74 75 61 6c 6c 79 20 66 61 69 6c 2e e actually fail.
4500: 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
4510: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e :file-exists? fn
4520: 61 6d 65 29 0a 09 28 69 66 20 28 3e 20 28 2d 20 ame)..(if (> (-
4530: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4540: 29 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 )(file-modificat
4550: 69 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 ion-time fname))
4560: 20 65 78 70 69 72 65 2d 74 69 6d 65 29 0a 09 20 expire-time)..
4570: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
4580: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 (delete-file* f
4590: 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 63 6f name).. (co
45a0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
45b0: 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 -lock fname expi
45c0: 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d re-time: expire-
45d0: 74 69 6d 65 29 29 0a 09 20 20 20 20 23 66 29 0a time)).. #f).
45e0: 09 28 6c 65 74 20 28 28 6b 65 79 2d 73 74 72 69 .(let ((key-stri
45f0: 6e 67 20 28 63 6f 6e 63 20 28 67 65 74 2d 68 6f ng (conc (get-ho
4600: 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 75 st-name) "-" (cu
4610: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
4620: 29 29 29 29 0a 09 20 20 28 77 69 74 68 2d 6f 75 )))).. (with-ou
4630: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e 61 tput-to-file fna
4640: 6d 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 me.. (lambda
4650: 28 29 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 ().. (print
4660: 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 key-string)))..
4670: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
4680: 20 30 2e 32 35 29 0a 09 20 20 28 69 66 20 28 63 0.25).. (if (c
4690: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
46a0: 73 3f 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 s? fname)..
46b0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
46c0: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 28 m-file fname...(
46d0: 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 28 65 lambda ()... (e
46e0: 71 75 61 6c 3f 20 6b 65 79 2d 73 74 72 69 6e 67 qual? key-string
46f0: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 0a (read-line)))).
4700: 09 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a . #f)))))..
4710: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
4720: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
4730: 2d 61 6e 64 2d 77 61 69 74 20 66 6e 61 6d 65 20 -and-wait fname
4740: 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 #!key (expire-ti
4750: 6d 65 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 me 300)). (let
4760: 28 28 65 6e 64 2d 74 69 6d 65 20 28 2b 20 65 78 ((end-time (+ ex
4770: 70 69 72 65 2d 74 69 6d 65 20 28 63 75 72 72 65 pire-time (curre
4780: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 nt-seconds)))).
4790: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 67 (let loop ((g
47a0: 6f 74 2d 6c 6f 63 6b 20 28 63 6f 6d 6d 6f 6e 3a ot-lock (common:
47b0: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
47c0: 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 fname expire-ti
47d0: 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 me: expire-time)
47e0: 29 29 0a 20 20 20 20 20 20 28 69 66 20 67 6f 74 )). (if got
47f0: 2d 6c 6f 63 6b 0a 09 20 20 23 74 0a 09 20 20 28 -lock.. #t.. (
4800: 69 66 20 28 3e 20 65 6e 64 2d 74 69 6d 65 20 28 if (> end-time (
4810: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4820: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
4830: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
4840: 20 33 29 0a 09 09 28 6c 6f 6f 70 20 28 63 6f 6d 3)...(loop (com
4850: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
4860: 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 lock fname expir
4870: 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 e-time: expire-t
4880: 69 6d 65 29 29 29 0a 09 20 20 20 20 20 20 23 66 ime))).. #f
4890: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
48a0: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
48b0: 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 le-release-lock
48c0: 66 6e 61 6d 65 29 0a 20 20 28 68 61 6e 64 6c 65 fname). (handle
48d0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
48e0: 20 20 65 78 6e 0a 20 20 20 20 20 20 23 66 20 3b exn. #f ;
48f0: 3b 20 49 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 ; I don't really
4900: 20 63 61 72 65 20 77 68 79 20 74 68 69 73 20 66 care why this f
4910: 61 69 6c 65 64 20 28 61 74 20 6c 65 61 73 74 20 ailed (at least
4920: 66 6f 72 20 6e 6f 77 29 0a 20 20 20 20 28 64 65 for now). (de
4930: 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 lete-file* fname
4940: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
4950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
4990: 20 53 20 54 20 41 20 54 20 45 20 53 20 20 20 41 S T A T E S A
49a0: 20 4e 20 44 20 20 20 53 20 54 20 41 20 54 20 55 N D S T A T U
49b0: 20 53 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d S E S.;;=======
49c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
4a00: 0a 3b 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d .;; BBnote: *com
4a10: 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 65 73 2a 20 mon:std-states*
4a20: 2d 20 64 61 73 68 62 6f 61 72 64 20 66 69 6c 74 - dashboard filt
4a30: 65 72 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 er control and t
4a40: 65 73 74 20 63 6f 6e 74 72 6f 6c 20 73 74 61 74 est control stat
4a50: 65 20 62 75 74 74 6f 6e 73 20 64 65 66 69 6e 65 e buttons define
4a60: 64 20 68 65 72 65 3b 20 75 73 65 64 20 69 6e 20 d here; used in
4a70: 73 65 74 2d 66 69 65 6c 64 73 2d 70 61 6e 65 6c set-fields-panel
4a80: 20 61 6e 64 20 64 62 6f 61 72 64 3a 6d 61 6b 65 and dboard:make
4a90: 2d 63 6f 6e 74 72 6f 6c 73 0a 28 64 65 66 69 6e -controls.(defin
4aa0: 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 e *common:std-st
4ab0: 61 74 65 73 2a 20 20 20 3b 3b 20 66 6f 72 20 74 ates* ;; for t
4ac0: 6f 67 67 6c 65 20 62 75 74 74 6f 6e 73 20 69 6e oggle buttons in
4ad0: 20 64 61 73 68 62 6f 61 72 64 0a 20 20 27 28 28 dashboard. '((
4ae0: 30 20 22 41 52 43 48 49 56 45 44 22 29 0a 20 20 0 "ARCHIVED").
4af0: 20 20 28 31 20 22 53 54 55 43 4b 22 29 0a 20 20 (1 "STUCK").
4b00: 20 20 28 32 20 22 4b 49 4c 4c 52 45 51 22 29 0a (2 "KILLREQ").
4b10: 20 20 20 20 28 33 20 22 4b 49 4c 4c 45 44 22 29 (3 "KILLED")
4b20: 0a 20 20 20 20 28 34 20 22 4e 4f 54 5f 53 54 41 . (4 "NOT_STA
4b30: 52 54 45 44 22 29 0a 20 20 20 20 28 35 20 22 43 RTED"). (5 "C
4b40: 4f 4d 50 4c 45 54 45 44 22 29 0a 20 20 20 20 28 OMPLETED"). (
4b50: 36 20 22 4c 41 55 4e 43 48 45 44 22 29 0a 20 20 6 "LAUNCHED").
4b60: 20 20 28 37 20 22 52 45 4d 4f 54 45 48 4f 53 54 (7 "REMOTEHOST
4b70: 53 54 41 52 54 22 29 0a 20 20 20 20 28 38 20 22 START"). (8 "
4b80: 52 55 4e 4e 49 4e 47 22 29 0a 20 20 20 20 29 29 RUNNING"). ))
4b90: 0a 0a 3b 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f ..;; BBnote: *co
4ba0: 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 75 73 65 mmon:std-statuse
4bb0: 73 2a 20 64 61 73 68 62 6f 61 72 64 20 66 69 6c s* dashboard fil
4bc0: 74 65 72 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 ter control and
4bd0: 74 65 73 74 20 63 6f 6e 74 72 6f 6c 20 73 74 61 test control sta
4be0: 74 75 73 20 62 75 74 74 6f 6e 73 20 64 65 66 69 tus buttons defi
4bf0: 6e 65 64 20 68 65 72 65 3b 20 75 73 65 64 20 69 ned here; used i
4c00: 6e 20 73 65 74 2d 66 69 65 6c 64 73 2d 70 61 6e n set-fields-pan
4c10: 65 6c 20 61 6e 64 20 64 62 6f 61 72 64 3a 6d 61 el and dboard:ma
4c20: 6b 65 2d 63 6f 6e 74 72 6f 6c 73 0a 28 64 65 66 ke-controls.(def
4c30: 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d ine *common:std-
4c40: 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 3b 3b statuses*. '(;;
4c50: 20 28 30 20 22 44 45 4c 45 54 45 44 22 29 0a 20 (0 "DELETED").
4c60: 20 20 20 28 31 20 22 6e 2f 61 22 29 0a 20 20 20 (1 "n/a").
4c70: 20 28 32 20 22 50 41 53 53 22 29 0a 20 20 20 20 (2 "PASS").
4c80: 28 33 20 22 53 4b 49 50 22 29 0a 20 20 20 20 28 (3 "SKIP"). (
4c90: 34 20 22 57 41 52 4e 22 29 0a 20 20 20 20 28 35 4 "WARN"). (5
4ca0: 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 20 28 "WAIVED"). (
4cb0: 36 20 22 43 48 45 43 4b 22 29 0a 20 20 20 20 28 6 "CHECK"). (
4cc0: 37 20 22 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 7 "STUCK/DEAD").
4cd0: 20 20 20 20 28 38 20 22 46 41 49 4c 22 29 0a 20 (8 "FAIL").
4ce0: 20 20 20 28 39 20 22 41 42 4f 52 54 22 29 29 29 (9 "ABORT")))
4cf0: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f ..(define *commo
4d00: 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 n:ended-states*
4d10: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 73 20 ;; states
4d20: 77 68 69 63 68 20 69 6e 64 69 63 61 74 65 20 74 which indicate t
4d30: 68 65 20 74 65 73 74 20 69 73 20 73 74 6f 70 70 he test is stopp
4d40: 65 64 20 61 6e 64 20 77 69 6c 6c 20 6e 6f 74 20 ed and will not
4d50: 70 72 6f 63 65 65 64 0a 20 20 27 28 22 43 4f 4d proceed. '("COM
4d60: 50 4c 45 54 45 44 22 20 22 41 52 43 48 49 56 45 PLETED" "ARCHIVE
4d70: 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 4b 49 4c D" "KILLED" "KIL
4d80: 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 22 49 LREQ" "STUCK" "I
4d90: 4e 43 4f 4d 50 4c 45 54 45 22 29 29 0a 0a 28 64 NCOMPLETE"))..(d
4da0: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 62 61 efine *common:ba
4db0: 64 6c 79 2d 65 6e 64 65 64 2d 73 74 61 74 65 73 dly-ended-states
4dc0: 2a 20 3b 3b 20 74 68 65 73 65 20 72 6f 6c 6c 20 * ;; these roll
4dd0: 75 70 20 61 73 20 43 48 45 43 4b 2c 20 69 2e 65 up as CHECK, i.e
4de0: 2e 20 72 65 73 75 6c 74 73 20 6e 65 65 64 20 74 . results need t
4df0: 6f 20 62 65 20 63 68 65 63 6b 65 64 0a 20 20 27 o be checked. '
4e00: 28 22 4b 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 ("KILLED" "KILLR
4e10: 45 51 22 20 22 53 54 55 43 4b 22 20 22 49 4e 43 EQ" "STUCK" "INC
4e20: 4f 4d 50 4c 45 54 45 22 20 22 44 45 41 44 22 29 OMPLETE" "DEAD")
4e30: 29 0a 0a 3b 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 )..;; BBnote: *c
4e40: 6f 6d 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 ommon:running-st
4e50: 61 74 65 73 2a 20 75 73 65 64 20 66 72 6f 6d 20 ates* used from
4e60: 64 62 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 db:set-state-sta
4e70: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
4e80: 69 74 65 6d 73 0a 28 64 65 66 69 6e 65 20 2a 63 items.(define *c
4e90: 6f 6d 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 ommon:running-st
4ea0: 61 74 65 73 2a 20 20 20 20 20 3b 3b 20 74 65 73 ates* ;; tes
4eb0: 74 20 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e t is either runn
4ec0: 69 6e 67 20 6f 72 20 63 61 6e 20 62 65 20 72 75 ing or can be ru
4ed0: 6e 0a 20 20 27 28 22 52 55 4e 4e 49 4e 47 22 20 n. '("RUNNING"
4ee0: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
4ef0: 22 20 22 4c 41 55 4e 43 48 45 44 22 20 22 53 54 " "LAUNCHED" "ST
4f00: 41 52 54 45 44 22 29 29 0a 0a 28 64 65 66 69 6e ARTED"))..(defin
4f10: 65 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 e *common:cant-r
4f20: 75 6e 2d 73 74 61 74 65 73 2a 20 20 20 20 3b 3b un-states* ;;
4f30: 20 54 68 65 73 65 20 61 72 65 20 73 74 6f 70 70 These are stopp
4f40: 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e 73 20 74 ing conditions t
4f50: 68 61 74 20 70 72 65 76 65 6e 74 20 61 20 74 65 hat prevent a te
4f60: 73 74 20 66 72 6f 6d 20 62 65 69 6e 67 20 72 75 st from being ru
4f70: 6e 0a 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 n. '("COMPLETED
4f80: 22 20 22 4b 49 4c 4c 45 44 22 20 22 55 4e 4b 4e " "KILLED" "UNKN
4f90: 4f 57 4e 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 OWN" "INCOMPLETE
4fa0: 22 20 22 41 52 43 48 49 56 45 44 22 29 29 0a 0a " "ARCHIVED"))..
4fb0: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
4fc0: 6e 6f 74 2d 73 74 61 72 74 65 64 2d 6f 6b 2d 73 not-started-ok-s
4fd0: 74 61 74 75 73 65 73 2a 20 3b 3b 20 69 66 20 6e tatuses* ;; if n
4fe0: 6f 74 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 ot one of these
4ff0: 73 74 61 74 75 73 65 73 20 77 68 65 6e 20 69 6e statuses when in
5000: 20 6e 6f 74 5f 73 74 61 72 74 65 64 20 73 74 61 not_started sta
5010: 74 65 20 74 72 65 61 74 20 61 73 20 64 65 61 64 te treat as dead
5020: 0a 20 20 27 28 22 6e 2f 61 22 20 22 6e 61 22 20 . '("n/a" "na"
5030: 22 50 41 53 53 22 20 22 46 41 49 4c 22 20 22 57 "PASS" "FAIL" "W
5040: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 ARN" "CHECK" "WA
5050: 49 56 45 44 22 20 22 44 45 41 44 22 20 22 53 4b IVED" "DEAD" "SK
5060: 49 50 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 IP"))..(define (
5070: 63 6f 6d 6d 6f 6e 3a 73 70 65 63 69 61 6c 2d 73 common:special-s
5080: 6f 72 74 20 69 74 65 6d 73 20 6f 72 64 65 72 20 ort items order
5090: 63 6f 6d 70 29 0a 20 20 28 6c 65 74 20 28 28 69 comp). (let ((i
50a0: 74 65 6d 73 2d 6f 72 64 65 72 20 28 6d 61 70 20 tems-order (map
50b0: 72 65 76 65 72 73 65 20 6f 72 64 65 72 29 29 0a reverse order)).
50c0: 20 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 20 (acomp
50d0: 20 20 20 20 20 28 6f 72 20 63 6f 6d 70 20 3e 29 (or comp >)
50e0: 29 29 0a 20 20 20 20 28 73 6f 72 74 20 69 74 65 )). (sort ite
50f0: 6d 73 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 ms. (lamb
5100: 64 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 da (a b).
5110: 20 20 20 28 6c 65 74 20 28 28 61 2d 6e 75 6d 20 (let ((a-num
5120: 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 (cadr (or (assoc
5130: 20 61 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 a items-order)
5140: 27 28 30 20 30 29 29 29 29 0a 20 20 20 20 20 20 '(0 0)))).
5150: 20 20 20 20 20 20 20 20 20 20 28 62 2d 6e 75 6d (b-num
5160: 20 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f (cadr (or (asso
5170: 63 20 62 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 c b items-order)
5180: 20 27 28 30 20 30 29 29 29 29 29 0a 20 20 20 20 '(0 0))))).
5190: 20 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 61 (acomp a
51a0: 2d 6e 75 6d 20 62 2d 6e 75 6d 29 29 29 29 29 29 -num b-num))))))
51b0: 0a 0a 3b 3b 20 3b 3b 20 67 69 76 65 6e 20 61 20 ..;; ;; given a
51c0: 74 6f 70 6c 65 76 65 6c 20 77 69 74 68 20 63 75 toplevel with cu
51d0: 72 72 73 74 61 74 65 2c 20 63 75 72 72 73 74 61 rrstate, currsta
51e0: 74 75 73 20 61 70 70 6c 79 20 73 74 61 74 65 20 tus apply state
51f0: 61 6e 64 20 73 74 61 74 75 73 0a 3b 3b 20 3b 3b and status.;; ;;
5200: 20 20 3d 3e 20 28 6e 65 77 73 74 61 74 65 20 2e => (newstate .
5210: 20 6e 65 77 73 74 61 74 75 73 29 0a 3b 3b 20 28 newstatus).;; (
5220: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 define (common:a
5230: 70 70 6c 79 2d 73 74 61 74 65 2d 73 74 61 74 75 pply-state-statu
5240: 73 20 63 75 72 72 73 74 61 74 65 20 63 75 72 72 s currstate curr
5250: 73 74 61 74 75 73 20 73 74 61 74 65 20 73 74 61 status state sta
5260: 74 75 73 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 tus).;; (let*
5270: 28 28 63 73 74 61 74 65 20 20 28 73 74 72 69 6e ((cstate (strin
5280: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
5290: 67 2d 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 g-downcase currs
52a0: 74 61 74 65 29 29 29 0a 3b 3b 20 20 20 20 20 20 tate))).;;
52b0: 20 20 20 20 28 63 73 74 61 74 75 73 20 28 73 74 (cstatus (st
52c0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 ring->symbol (st
52d0: 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 63 75 ring-downcase cu
52e0: 72 72 73 74 61 74 75 73 29 29 29 0a 3b 3b 20 20 rrstatus))).;;
52f0: 20 20 20 20 20 20 20 20 28 73 73 74 61 74 65 20 (sstate
5300: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
5310: 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 (string-downcas
5320: 65 20 73 74 61 74 65 29 29 29 0a 3b 3b 20 20 20 e state))).;;
5330: 20 20 20 20 20 20 20 28 73 73 74 61 74 75 73 20 (sstatus
5340: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
5350: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
5360: 20 73 74 61 74 75 73 29 29 29 0a 3b 3b 20 20 20 status))).;;
5370: 20 20 20 20 20 20 20 28 6e 73 74 61 74 65 20 20 (nstate
5380: 23 66 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 #f).;;
5390: 28 6e 73 74 61 74 75 73 20 23 66 29 29 0a 3b 3b (nstatus #f)).;;
53a0: 20 20 20 20 20 28 73 65 74 21 20 6e 73 74 61 74 (set! nstat
53b0: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 e.;; (
53c0: 63 61 73 65 20 63 73 74 61 74 65 0a 3b 3b 20 20 case cstate.;;
53d0: 20 20 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d ((com
53e0: 70 6c 65 74 65 64 20 6e 6f 74 5f 73 74 61 72 74 pleted not_start
53f0: 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 ed killed killre
5400: 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 q stuck archived
5410: 29 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ) .;;
5420: 20 20 20 28 63 61 73 65 20 73 73 74 61 74 65 20 (case sstate
5430: 3b 3b 20 63 6f 6d 70 6c 65 74 65 64 20 2d 3e 20 ;; completed ->
5440: 73 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 sstate.;;
5450: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c ((compl
5460: 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c eted killed kill
5470: 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 req stuck archiv
5480: 65 64 29 20 63 6f 6d 70 6c 65 74 65 64 29 0a 3b ed) completed).;
5490: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
54a0: 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 ((running remot
54b0: 65 68 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 ehoststart launc
54c0: 68 65 64 29 20 20 20 20 20 20 20 20 72 75 6e 6e hed) runn
54d0: 69 6e 67 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ing).;;
54e0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
54f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5510: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
5520: 31 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 1))).;;
5530: 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 ((running re
5540: 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c 61 motehoststart la
5550: 75 6e 63 68 65 64 29 0a 3b 3b 20 20 20 20 20 20 unched).;;
5560: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 (case ss
5570: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
5580: 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 ((complet
5590: 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 ed killed killre
55a0: 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 q stuck archived
55b0: 29 20 23 66 29 20 3b 3b 20 6e 65 65 64 20 74 6f ) #f) ;; need to
55c0: 20 6c 6f 6f 6b 20 61 74 20 61 6c 6c 20 69 74 65 look at all ite
55d0: 6d 73 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ms.;;
55e0: 20 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 ((running r
55f0: 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c emotehoststart l
5600: 61 75 6e 63 68 65 64 29 20 20 20 20 20 20 20 20 aunched)
5610: 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 20 20 20 20 running).;;
5620: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
5630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5650: 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 unknown-er
5660: 72 6f 72 2d 32 29 29 29 0a 3b 3b 20 20 20 20 20 ror-2))).;;
5670: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 75 6e (else un
5680: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 33 29 29 29 known-error-3)))
5690: 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 20 6e 73 .;; (set! ns
56a0: 74 61 74 75 73 0a 3b 3b 20 20 20 20 20 20 20 20 tatus.;;
56b0: 20 20 20 28 63 61 73 65 20 73 73 74 61 74 75 73 (case sstatus
56c0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
56d0: 28 28 70 61 73 73 29 0a 3b 3b 20 20 20 20 20 20 ((pass).;;
56e0: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 (case ns
56f0: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
5700: 20 20 20 20 20 20 20 28 28 70 61 73 73 20 6e 2f ((pass n/
5710: 61 20 64 65 6c 65 74 65 64 29 20 20 20 20 20 70 a deleted) p
5720: 61 73 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ass).;;
5730: 20 20 20 20 20 20 20 28 28 77 61 72 6e 29 20 20 ((warn)
5740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 77 w
5750: 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 arn).;;
5760: 20 20 20 20 20 20 20 28 28 66 61 69 6c 29 20 20 ((fail)
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 f
5780: 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ail).;;
5790: 20 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 ((check)
57a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 68 ch
57b0: 65 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 eck).;;
57c0: 20 20 20 20 20 20 20 28 28 77 61 69 76 65 64 29 ((waived)
57d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 wai
57e0: 76 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ved).;;
57f0: 20 20 20 20 20 20 20 28 28 73 6b 69 70 29 20 20 ((skip)
5800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
5810: 6b 69 70 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 kip).;;
5820: 20 20 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 ((stuck/d
5830: 65 61 64 29 20 20 20 20 20 20 20 20 20 20 73 74 ead) st
5840: 75 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 uck).;;
5850: 20 20 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 ((abort)
5860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 62 ab
5870: 6f 72 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ort).;;
5880: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
5890: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
58a0: 72 2d 34 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 r-4))).;;
58b0: 20 20 20 20 20 20 28 28 77 61 72 6e 29 0a 3b 3b ((warn).;;
58c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
58d0: 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 ase nstate.;;
58e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 ((p
58f0: 61 73 73 20 77 61 72 6e 20 6e 2f 61 20 73 6b 69 ass warn n/a ski
5900: 70 20 64 65 6c 65 74 65 64 29 20 20 20 77 61 72 p deleted) war
5910: 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 n).;;
5920: 20 20 20 20 20 28 28 66 61 69 6c 29 20 20 20 20 ((fail)
5930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5940: 20 20 20 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 fail).;;
5950: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
5960: 68 65 63 6b 29 20 20 20 20 20 20 20 20 20 20 20 heck)
5970: 20 20 20 20 20 20 20 20 20 20 20 20 63 68 65 63 chec
5980: 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 k).;;
5990: 20 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 ((waived)
59a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59b0: 20 20 20 77 61 69 76 65 64 29 0a 3b 3b 20 20 20 waived).;;
59c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
59d0: 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 20 20 tuck/dead)
59e0: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 75 63 stuc
59f0: 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 k).;;
5a00: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
5a10: 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 unknow
5a20: 6e 2d 65 72 72 6f 72 2d 35 29 29 29 0a 3b 3b 20 n-error-5))).;;
5a30: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 ((fa
5a40: 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 il).;;
5a50: 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 (case nstate
5a60: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5a70: 20 20 20 28 28 70 61 73 73 20 77 61 72 6e 20 66 ((pass warn f
5a80: 61 69 6c 20 63 68 65 63 6b 20 6e 2f 61 20 77 61 ail check n/a wa
5a90: 69 76 65 64 20 73 6b 69 70 20 64 65 6c 65 74 65 ived skip delete
5aa0: 64 20 73 74 75 63 6b 2f 64 65 61 64 20 73 74 75 d stuck/dead stu
5ab0: 63 6b 29 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 ck) fail).;;
5ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
5ad0: 62 6f 72 74 29 20 20 20 20 20 20 20 20 20 20 20 bort)
5ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 62 ab
5b10: 6f 72 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ort).;;
5b20: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
5b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e un
5b60: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 36 29 29 29 known-error-6)))
5b70: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5b80: 28 65 6c 73 65 20 20 20 20 75 6e 6b 6e 6f 77 6e (else unknown
5b90: 2d 65 72 72 6f 72 2d 37 29 29 29 0a 3b 3b 20 20 -error-7))).;;
5ba0: 20 20 20 28 63 6f 6e 73 20 0a 3b 3b 20 20 20 20 (cons .;;
5bb0: 20 20 28 69 66 20 6e 73 74 61 74 65 20 20 28 73 (if nstate (s
5bc0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 ymbol->string ns
5bd0: 74 61 74 65 29 20 20 6e 73 74 61 74 65 29 0a 3b tate) nstate).;
5be0: 3b 20 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 ; (if nstat
5bf0: 75 73 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 us (symbol->stri
5c00: 6e 67 20 6e 73 74 61 74 75 73 29 20 6e 73 74 61 ng nstatus) nsta
5c10: 74 75 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 tus)))).
5c20: 20 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d .;;======
5c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c70: 0a 3b 3b 20 44 20 45 20 42 20 55 20 47 20 47 20 .;; D E B U G G
5c80: 49 20 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 I N G S T U F
5c90: 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F .;;===========
5ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
5ce0: 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2a fine *verbosity*
5cf0: 20 20 20 20 20 20 20 20 20 31 29 0a 28 64 65 66 1).(def
5d00: 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 20 ine *logging*
5d10: 20 20 20 20 20 20 20 20 23 66 29 0a 0a 28 64 65 #f)..(de
5d20: 66 69 6e 65 20 28 67 65 74 2d 77 69 74 68 2d 64 fine (get-with-d
5d30: 65 66 61 75 6c 74 20 76 61 6c 20 64 65 66 61 75 efault val defau
5d40: 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c lt). (let ((val
5d50: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 76 (args:get-arg v
5d60: 61 6c 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 al))). (if va
5d70: 6c 20 76 61 6c 20 64 65 66 61 75 6c 74 29 29 29 l val default)))
5d80: 0a 0a 28 64 65 66 69 6e 65 20 28 61 73 73 6f 63 ..(define (assoc
5d90: 2f 64 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 /default key lst
5da0: 20 2e 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c . default). (l
5db0: 65 74 20 28 28 72 65 73 20 28 61 73 73 6f 63 20 et ((res (assoc
5dc0: 6b 65 79 20 6c 73 74 29 29 29 0a 20 20 20 20 28 key lst))). (
5dd0: 69 66 20 72 65 73 20 28 63 61 64 72 20 72 65 73 if res (cadr res
5de0: 29 28 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 )(if (null? defa
5df0: 75 6c 74 29 20 23 66 20 28 63 61 72 20 64 65 66 ult) #f (car def
5e00: 61 75 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 ault)))))..(defi
5e10: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 ne (common:get-t
5e20: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 20 estsuite-name).
5e30: 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (or (configf:lo
5e40: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
5e50: 20 22 73 65 74 75 70 22 20 22 61 72 65 61 2d 6e "setup" "area-n
5e60: 61 6d 65 22 29 20 3b 3b 20 6d 65 67 61 74 65 73 ame") ;; megates
5e70: 74 20 69 73 20 61 20 66 6c 65 78 69 62 6c 65 20 t is a flexible
5e80: 74 6f 6f 6c 2c 20 74 65 73 74 73 75 69 74 65 20 tool, testsuite
5e90: 69 73 20 74 6f 6f 20 6c 69 6d 69 74 69 6e 67 20 is too limiting
5ea0: 61 20 64 65 73 63 72 69 70 74 69 6f 6e 2e 0a 20 a description..
5eb0: 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (configf:lo
5ec0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
5ed0: 20 22 73 65 74 75 70 22 20 22 74 65 73 74 73 75 "setup" "testsu
5ee0: 69 74 65 22 20 29 0a 20 20 20 20 20 20 28 67 65 ite" ). (ge
5ef0: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 53 55 49 tenv "MT_TESTSUI
5f00: 54 45 5f 4e 41 4d 45 22 29 0a 20 20 20 20 20 20 TE_NAME").
5f10: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 2a 74 6f (if (string? *to
5f20: 70 70 61 74 68 2a 20 29 0a 20 20 20 20 20 20 20 ppath* ).
5f30: 20 20 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c (pathname-fil
5f40: 65 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 e *toppath*).
5f50: 20 20 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 #f))) ;;
5f60: 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 (pathname-file (
5f70: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
5f80: 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y)))))..(define
5f90: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d common:get-area-
5fa0: 6e 61 6d 65 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d name common:get-
5fb0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a testsuite-name).
5fc0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
5fd0: 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 :get-db-tmp-area
5fe0: 20 2e 20 6a 75 6e 6b 29 0a 20 20 28 69 66 20 2a . junk). (if *
5ff0: 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 db-cache-path*.
6000: 20 20 20 20 20 2a 64 62 2d 63 61 63 68 65 2d 70 *db-cache-p
6010: 61 74 68 2a 0a 20 20 20 20 20 20 28 69 66 20 2a ath*. (if *
6020: 74 6f 70 70 61 74 68 2a 20 3b 3b 20 63 6f 6d 6d toppath* ;; comm
6030: 6f 6e 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 on:get-create-wr
6040: 69 74 65 61 62 6c 65 2d 64 69 72 0a 09 20 20 28 iteable-dir.. (
6050: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
6060: 73 0a 09 20 20 20 20 20 20 65 78 6e 0a 09 20 20 s.. exn..
6070: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 (begin...(de
6080: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
6090: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
60a0: 6f 72 74 2a 20 22 43 6f 75 6c 64 6e 27 74 20 63 ort* "Couldn't c
60b0: 72 65 61 74 65 20 70 61 74 68 20 74 6f 20 22 20 reate path to "
60c0: 64 62 64 69 72 29 0a 09 09 28 65 78 69 74 20 31 dbdir)...(exit 1
60d0: 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 64 )).. (let ((d
60e0: 62 70 61 74 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 bpath (common:ge
60f0: 74 2d 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 t-create-writeab
6100: 6c 65 2d 64 69 72 0a 09 09 09 20 20 20 28 6c 69 le-dir.... (li
6110: 73 74 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 st (conc "/tmp/"
6120: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
6130: 61 6d 65 29 0a 09 09 09 09 20 20 20 20 20 20 20 ame).....
6140: 22 2f 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c "/megatest_local
6150: 64 62 2f 22 0a 09 09 09 09 20 20 20 20 20 20 20 db/".....
6160: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 (common:get-test
6170: 73 75 69 74 65 2d 6e 61 6d 65 29 20 22 2f 22 0a suite-name) "/".
6180: 09 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
6190: 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 2a 74 6f ng-translate *to
61a0: 70 70 61 74 68 2a 20 22 2f 22 20 22 2e 22 29 29 ppath* "/" "."))
61b0: 29 29 29 29 20 3b 3b 20 20 23 74 29 29 29 29 0a )))) ;; #t)))).
61c0: 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 . (set! *db
61d0: 2d 63 61 63 68 65 2d 70 61 74 68 2a 20 64 62 70 -cache-path* dbp
61e0: 61 74 68 29 0a 09 20 20 20 20 20 20 64 62 70 61 ath).. dbpa
61f0: 74 68 29 29 0a 09 20 20 23 66 29 29 29 0a 0a 28 th)).. #f)))..(
6200: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
6210: 65 74 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 et-area-path-sig
6220: 6e 61 74 75 72 65 29 0a 20 20 28 6d 65 73 73 61 nature). (messa
6230: 67 65 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 ge-digest-string
6240: 20 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 (md5-primitive)
6250: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 0a 28 64 *toppath*))..(d
6260: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
6270: 74 2d 73 69 67 6e 61 74 75 72 65 20 73 74 72 29 t-signature str)
6280: 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 . (message-dige
6290: 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 st-string (md5-p
62a0: 72 69 6d 69 74 69 76 65 29 20 73 74 72 29 29 0a rimitive) str)).
62b0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
62c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
62d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
62e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
62f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 =========.;; E X
6300: 20 49 20 54 20 20 20 48 20 41 20 4e 20 44 20 4c I T H A N D L
6310: 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d I N G.;;=======
6320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
6360: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
6370: 3a 72 75 6e 2d 73 79 6e 63 3f 29 0a 20 20 20 20 :run-sync?).
6380: 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d (and (common:on-
6390: 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 28 61 72 homehost?).. (ar
63a0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 gs:get-arg "-ser
63b0: 76 65 72 22 29 29 29 0a 0a 3b 3b 20 20 20 28 6c ver")))..;; (l
63c0: 65 74 20 28 28 6f 68 68 20 28 63 6f 6d 6d 6f 6e et ((ohh (common
63d0: 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 29 0a :on-homehost?)).
63e0: 3b 3b 20 09 28 73 72 76 20 28 61 72 67 73 3a 67 ;; .(srv (args:g
63f0: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
6400: 29 29 29 0a 3b 3b 20 20 20 20 20 28 61 6e 64 20 ))).;; (and
6410: 6f 68 68 20 73 72 76 29 29 29 0a 20 20 20 20 3b ohh srv))). ;
6420: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ; (debug:print-i
6430: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
6440: 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e og-port* "common
6450: 3a 72 75 6e 2d 73 79 6e 63 3f 20 6f 68 68 3d 22 :run-sync? ohh="
6460: 20 6f 68 68 20 22 2c 20 73 72 76 3d 22 20 73 72 ohh ", srv=" sr
6470: 76 29 0a 0a 0a 0a 28 64 65 66 69 6e 65 20 2a 77 v)....(define *w
6480: 64 6e 75 6d 2a 20 30 29 0a 28 64 65 66 69 6e 65 dnum* 0).(define
6490: 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 20 28 6d *wdnum*mutex (m
64a0: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 63 ake-mutex)).;; c
64b0: 75 72 72 65 6e 74 6c 79 20 74 68 65 20 70 72 69 urrently the pri
64c0: 6d 61 72 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 mary job of the
64d0: 77 61 74 63 68 64 6f 67 20 69 73 20 74 6f 20 72 watchdog is to r
64e0: 75 6e 20 74 68 65 20 73 79 6e 63 20 62 61 63 6b un the sync back
64f0: 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 to megatest.db
6500: 66 72 6f 6d 20 74 68 65 20 64 62 20 69 6e 20 2f from the db in /
6510: 74 6d 70 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 tmp.;; if we are
6520: 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 on the homehost
6530: 20 61 6e 64 20 77 65 20 61 72 65 20 61 20 73 65 and we are a se
6540: 72 76 65 72 20 28 62 79 20 64 65 66 69 6e 69 74 rver (by definit
6550: 69 6f 6e 20 77 65 20 61 72 65 20 6f 6e 20 74 68 ion we are on th
6560: 65 20 68 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 e homehost if we
6570: 20 61 72 65 20 61 20 73 65 72 76 65 72 29 0a 3b are a server).;
6580: 3b 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ;...(define (com
6590: 6d 6f 6e 3a 72 65 61 64 6f 6e 6c 79 2d 77 61 74 mon:readonly-wat
65a0: 63 68 64 6f 67 20 64 62 73 74 72 75 63 74 29 0a chdog dbstruct).
65b0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
65c0: 20 30 2e 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 0.05) ;; delay
65d0: 66 6f 72 20 73 74 61 72 74 75 70 0a 20 20 28 64 for startup. (d
65e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
65f0: 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 13 *default-log-
6600: 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 65 port* "common:re
6610: 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 adonly-watchdog
6620: 65 6e 74 65 72 65 64 2e 22 29 0a 20 20 3b 3b 20 entered."). ;;
6630: 73 79 6e 63 20 6d 65 67 61 74 65 73 74 2e 64 62 sync megatest.db
6640: 20 74 6f 20 2f 74 6d 70 2f 2e 2e 2e 2f 6d 65 67 to /tmp/.../meg
6650: 61 74 73 74 2e 64 62 0a 20 20 28 6c 65 74 2a 20 atst.db. (let*
6660: 28 28 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d ((sync-cool-off-
6670: 64 75 72 61 74 69 6f 6e 20 20 20 33 29 0a 20 20 duration 3).
6680: 20 20 20 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 (golden-mt
6690: 64 62 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 db (dbr:dbst
66a0: 72 75 63 74 2d 6d 74 64 62 20 64 62 73 74 72 75 ruct-mtdb dbstru
66b0: 63 74 29 29 0a 20 20 20 20 20 20 20 20 28 67 6f ct)). (go
66c0: 6c 64 65 6e 2d 6d 74 70 61 74 68 20 20 20 28 64 lden-mtpath (d
66d0: 62 3a 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 b:dbdat-get-path
66e0: 20 67 6f 6c 64 65 6e 2d 6d 74 64 62 29 29 0a 20 golden-mtdb)).
66f0: 20 20 20 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 (tmp-mtdb
6700: 20 20 20 20 20 20 20 20 28 64 62 72 3a 64 62 73 (dbr:dbs
6710: 74 72 75 63 74 2d 74 6d 70 64 62 20 64 62 73 74 truct-tmpdb dbst
6720: 72 75 63 74 29 29 0a 20 20 20 20 20 20 20 20 28 ruct)). (
6730: 74 6d 70 2d 6d 74 70 61 74 68 20 20 20 20 20 20 tmp-mtpath
6740: 28 64 62 3a 64 62 64 61 74 2d 67 65 74 2d 70 61 (db:dbdat-get-pa
6750: 74 68 20 74 6d 70 2d 6d 74 64 62 29 29 29 0a 20 th tmp-mtdb))).
6760: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
6770: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
6780: 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 61 64 2d log-port* "Read-
6790: 6f 6e 6c 79 20 70 65 72 69 6f 64 69 63 20 73 79 only periodic sy
67a0: 6e 63 20 74 68 72 65 61 64 20 73 74 61 72 74 65 nc thread starte
67b0: 64 2e 22 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f d."). (let lo
67c0: 6f 70 20 28 28 6c 61 73 74 2d 73 79 6e 63 2d 74 op ((last-sync-t
67d0: 69 6d 65 20 30 29 29 0a 20 20 20 20 20 20 28 64 ime 0)). (d
67e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
67f0: 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 13 *default-log-
6800: 70 6f 72 74 2a 20 22 6c 6f 6f 70 20 74 6f 70 20 port* "loop top
6810: 74 6d 70 2d 6d 74 70 61 74 68 3d 22 74 6d 70 2d tmp-mtpath="tmp-
6820: 6d 74 70 61 74 68 22 20 67 6f 6c 64 65 6e 2d 6d mtpath" golden-m
6830: 74 70 61 74 68 3d 22 67 6f 6c 64 65 6e 2d 6d 74 tpath="golden-mt
6840: 70 61 74 68 29 0a 20 20 20 20 20 20 28 6c 65 74 path). (let
6850: 2a 20 28 28 64 75 72 61 74 69 6f 6e 2d 73 69 6e * ((duration-sin
6860: 63 65 2d 6c 61 73 74 2d 73 79 6e 63 20 28 2d 20 ce-last-sync (-
6870: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
6880: 29 20 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 ) last-sync-time
6890: 29 29 29 0a 20 20 20 20 20 20 20 20 28 64 65 62 ))). (deb
68a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
68b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
68c0: 72 74 2a 20 22 64 75 72 61 74 69 6f 6e 2d 73 69 rt* "duration-si
68d0: 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 3d 22 64 nce-last-sync="d
68e0: 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 uration-since-la
68f0: 73 74 2d 73 79 6e 63 29 0a 20 20 20 20 20 20 20 st-sync).
6900: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a (if (and (not *
6910: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 time-to-exit*).
6920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6930: 28 3c 20 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 (< duration-sinc
6940: 65 2d 6c 61 73 74 2d 73 79 6e 63 20 73 79 6e 63 e-last-sync sync
6950: 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 -cool-off-durati
6960: 6f 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 on)).
6970: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
6980: 28 2d 20 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 (- sync-cool-off
6990: 2d 64 75 72 61 74 69 6f 6e 20 64 75 72 61 74 69 -duration durati
69a0: 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 on-since-last-sy
69b0: 6e 63 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 nc))). (i
69c0: 66 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d f (not *time-to-
69d0: 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 exit*).
69e0: 20 20 20 28 6c 65 74 20 28 28 67 6f 6c 64 65 6e (let ((golden
69f0: 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 28 66 69 6c -mtdb-mtime (fil
6a00: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
6a10: 69 6d 65 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 ime golden-mtpat
6a20: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
6a30: 20 20 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 2d (tmp-mtdb-
6a40: 6d 74 69 6d 65 20 20 20 20 28 66 69 6c 65 2d 6d mtime (file-m
6a50: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
6a60: 20 74 6d 70 2d 6d 74 70 61 74 68 29 29 29 0a 09 tmp-mtpath)))..
6a70: 20 20 20 20 20 20 28 69 66 20 28 3e 20 67 6f 6c (if (> gol
6a80: 64 65 6e 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 74 den-mtdb-mtime t
6a90: 6d 70 2d 6d 74 64 62 2d 6d 74 69 6d 65 29 0a 09 mp-mtdb-mtime)..
6aa0: 09 20 20 28 69 66 20 28 3c 20 67 6f 6c 64 65 6e . (if (< golden
6ab0: 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 28 2d 20 28 -mtdb-mtime (- (
6ac0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
6ad0: 20 33 29 29 20 3b 3b 20 66 69 6c 65 20 68 61 73 3)) ;; file has
6ae0: 20 4e 4f 54 20 62 65 65 6e 20 74 6f 75 63 68 65 NOT been touche
6af0: 64 20 69 6e 20 70 61 73 74 20 74 68 72 65 65 20 d in past three
6b00: 73 65 63 6f 6e 64 73 2c 20 74 68 69 73 20 77 61 seconds, this wa
6b10: 79 20 6d 75 6c 74 69 70 6c 65 20 73 65 72 76 65 y multiple serve
6b20: 72 73 20 77 6f 6e 27 74 20 66 69 67 68 74 20 74 rs won't fight t
6b30: 6f 20 73 79 6e 63 20 62 61 63 6b 0a 09 09 20 20 o sync back...
6b40: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
6b50: 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 db:multi-db-sync
6b60: 20 64 62 73 74 72 75 63 74 20 27 6f 6c 64 32 6e dbstruct 'old2n
6b70: 65 77 29 29 29 0a 09 09 09 28 64 65 62 75 67 3a ew)))....(debug:
6b80: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
6b90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6ba0: 20 22 72 6f 73 79 6e 63 20 63 61 6c 6c 65 64 2c "rosync called,
6bb0: 20 22 20 72 65 73 20 22 20 72 65 63 6f 72 64 73 " res " records
6bc0: 20 74 72 61 6e 73 66 65 72 72 65 64 2e 22 29 29 transferred."))
6bd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6be0: 20 28 6c 6f 6f 70 20 28 63 75 72 72 65 6e 74 2d (loop (current-
6bf0: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 seconds))).
6c00: 20 20 20 20 20 20 20 23 74 29 29 29 0a 20 20 20 #t))).
6c10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
6c20: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
6c30: 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 g-port* "Exiting
6c40: 20 72 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 readonly-watchd
6c50: 6f 67 20 74 69 6d 65 72 2c 20 2a 74 69 6d 65 2d og timer, *time-
6c60: 74 6f 2d 65 78 69 74 2a 20 3d 20 22 20 2a 74 69 to-exit* = " *ti
6c70: 6d 65 2d 74 6f 2d 65 78 69 74 2a 22 20 70 69 64 me-to-exit*" pid
6c80: 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 ="(current-proce
6c90: 73 73 2d 69 64 29 22 20 6d 74 70 61 74 68 3d 22 ss-id)" mtpath="
6ca0: 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 29 29 golden-mtpath)))
6cb0: 0a 0a 3b 3b 20 54 4f 44 4f 3a 20 66 6f 72 20 6d ..;; TODO: for m
6cc0: 75 6c 74 69 70 6c 65 20 61 72 65 61 73 2c 20 77 ultiple areas, w
6cd0: 65 20 77 69 6c 6c 20 68 61 76 65 20 6d 75 6c 74 e will have mult
6ce0: 69 70 6c 65 20 77 61 74 63 68 64 6f 67 73 3b 20 iple watchdogs;
6cf0: 61 6e 64 20 6d 75 6c 74 69 70 6c 65 20 74 68 72 and multiple thr
6d00: 65 61 64 73 20 74 6f 20 6d 61 6e 61 67 65 0a 28 eads to manage.(
6d10: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
6d20: 61 74 63 68 64 6f 67 29 0a 20 20 28 64 65 62 75 atchdog). (debu
6d30: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
6d40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6d50: 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 t* "common:watch
6d60: 64 6f 67 20 65 6e 74 65 72 65 64 2e 22 29 0a 20 dog entered.").
6d70: 20 28 69 66 20 28 6c 61 75 6e 63 68 3a 73 65 74 (if (launch:set
6d80: 75 70 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 up). (if (c
6d90: 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 ommon:on-homehos
6da0: 74 3f 29 0a 09 20 20 28 6c 65 74 20 28 28 64 62 t?).. (let ((db
6db0: 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 struct (db:setup
6dc0: 20 23 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 #t))).. (deb
6dd0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
6de0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6df0: 72 74 2a 20 22 61 66 74 65 72 20 64 62 3a 73 65 rt* "after db:se
6e00: 74 75 70 20 77 69 74 68 20 64 62 73 74 72 75 63 tup with dbstruc
6e10: 74 3d 22 20 64 62 73 74 72 75 63 74 29 0a 09 20 t=" dbstruct)..
6e20: 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 (cond.. (
6e30: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 72 65 (dbr:dbstruct-re
6e40: 61 64 2d 6f 6e 6c 79 20 64 62 73 74 72 75 63 74 ad-only dbstruct
6e50: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
6e60: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
6e70: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6e80: 20 22 6c 6f 61 64 69 6e 67 20 72 65 61 64 2d 6f "loading read-o
6e90: 6e 6c 79 20 77 61 74 63 68 64 6f 67 22 29 0a 09 nly watchdog")..
6ea0: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 72 65 (common:re
6eb0: 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 adonly-watchdog
6ec0: 64 62 73 74 72 75 63 74 29 29 0a 09 20 20 20 20 dbstruct))..
6ed0: 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 64 (else.. (d
6ee0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6ef0: 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 13 *default-log-
6f00: 70 6f 72 74 2a 20 22 6c 6f 61 64 69 6e 67 20 77 port* "loading w
6f10: 72 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 ritable-watchdog
6f20: 2e 22 29 0a 09 20 20 20 20 20 20 28 73 65 72 76 .").. (serv
6f30: 65 72 3a 77 72 69 74 61 62 6c 65 2d 77 61 74 63 er:writable-watc
6f40: 68 64 6f 67 20 64 62 73 74 72 75 63 74 29 29 29 hdog dbstruct)))
6f50: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
6f60: 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 nt-info 13 *defa
6f70: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
6f80: 61 74 63 68 64 6f 67 20 64 6f 6e 65 2e 22 29 29 atchdog done."))
6f90: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
6fa0: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
6fb0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 20 t-log-port* "no
6fc0: 6e 65 65 64 20 66 6f 72 20 77 61 74 63 68 64 6f need for watchdo
6fd0: 67 20 6f 6e 20 6e 6f 6e 2d 68 6f 6d 65 68 6f 73 g on non-homehos
6fe0: 74 22 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 t"))))...(define
6ff0: 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 (std-exit-proce
7000: 64 75 72 65 29 0a 20 20 28 6f 6e 2d 65 78 69 74 dure). (on-exit
7010: 20 28 6c 61 6d 62 64 61 20 28 29 20 30 29 29 0a (lambda () 0)).
7020: 20 20 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 ;;(debug:print
7030: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
7040: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 64 t-log-port* "std
7050: 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 65 20 -exit-procedure
7060: 63 61 6c 6c 65 64 3b 20 2a 74 69 6d 65 2d 74 6f called; *time-to
7070: 2d 65 78 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 6f -exit*="*time-to
7080: 2d 65 78 69 74 2a 29 0a 20 20 28 6c 65 74 20 28 -exit*). (let (
7090: 28 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 20 2a (no-hurry (if *
70a0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b time-to-exit* ;;
70b0: 20 68 75 72 72 79 20 75 70 0a 09 09 20 20 20 20 hurry up...
70c0: 20 20 20 23 66 0a 09 09 20 20 20 20 20 20 20 28 #f... (
70d0: 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 begin.... (set!
70e0: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 *time-to-exit* #
70f0: 74 29 0a 09 09 09 20 23 74 29 29 29 29 0a 20 20 t).... #t)))).
7100: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7110: 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 4 *default-l
7120: 6f 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 69 og-port* "starti
7130: 6e 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 2c ng exit process,
7140: 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 61 finalizing data
7150: 62 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 66 bases."). (if
7160: 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 28 (and no-hurry (
7170: 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 debug:debug-mode
7180: 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 6e 18))..(rmt:prin
7190: 74 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 20 20 t-db-stats)).
71a0: 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b (let ((th1 (mak
71b0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
71c0: 20 28 29 20 3b 3b 20 74 68 72 65 61 64 20 66 6f () ;; thread fo
71d0: 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 67 r cleaning up, g
71e0: 69 76 65 20 69 74 20 66 69 76 65 20 73 65 63 6f ive it five seco
71f0: 6e 64 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 nds.
7200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7210: 20 20 28 69 66 20 2a 64 62 73 74 72 75 63 74 2d (if *dbstruct-
7220: 64 62 2a 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c db* (db:close-al
7230: 6c 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 29 l *dbstruct-db*)
7240: 29 20 3b 3b 20 6f 6e 65 20 73 65 63 6f 6e 64 20 ) ;; one second
7250: 61 6c 6c 6f 63 61 74 65 64 0a 09 09 09 20 20 20 allocated....
7260: 20 20 20 28 69 66 20 2a 74 61 73 6b 2d 64 62 2a (if *task-db*
7270: 20 20 20 20 0a 09 09 09 09 20 20 28 6c 65 74 20 ..... (let
7280: 28 28 64 62 20 28 63 64 72 20 2a 74 61 73 6b 2d ((db (cdr *task-
7290: 64 62 2a 29 29 29 0a 09 09 09 09 20 20 20 20 28 db*)))..... (
72a0: 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 if (sqlite3:data
72b0: 62 61 73 65 3f 20 64 62 29 0a 09 09 09 09 09 28 base? db)......(
72c0: 62 65 67 69 6e 0a 09 09 09 09 09 20 20 28 73 71 begin...... (sq
72d0: 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 70 74 21 lite3:interrupt!
72e0: 20 64 62 29 0a 09 09 09 09 09 20 20 28 73 71 6c db)...... (sql
72f0: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
7300: 62 20 23 74 29 0a 09 09 09 09 09 20 20 3b 3b 20 b #t)...... ;;
7310: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 2a 74 61 (vector-set! *ta
7320: 73 6b 2d 64 62 2a 20 30 20 23 66 29 0a 09 09 09 sk-db* 0 #f)....
7330: 09 09 20 20 28 73 65 74 21 20 2a 74 61 73 6b 2d .. (set! *task-
7340: 64 62 2a 20 23 66 29 29 29 29 29 0a 20 20 20 20 db* #f))))).
7350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7360: 20 20 20 20 20 20 20 20 20 20 28 68 74 74 70 2d (http-
7370: 63 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c client#close-all
7380: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 0a 20 -connections!).
7390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
73b0: 28 69 66 20 28 61 6e 64 20 2a 72 75 6e 72 65 6d (if (and *runrem
73c0: 6f 74 65 2a 0a 20 20 20 20 20 20 20 20 20 20 20 ote*.
73d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73e0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 ;; (
73f0: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a remote-conndat *
7400: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 20 20 20 runremote*)).
7410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7420: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ;;
7430: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
7440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7450: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
7460: 28 68 74 74 70 2d 63 6c 69 65 6e 74 23 63 6c 6f (http-client#clo
7470: 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f se-all-connectio
7480: 6e 73 21 29 29 29 20 3b 3b 20 66 6f 72 20 68 74 ns!))) ;; for ht
7490: 74 70 2d 63 6c 69 65 6e 74 0a 20 20 20 20 20 20 tp-client.
74a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
74b0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
74c0: 20 28 65 71 3f 20 2a 64 65 66 61 75 6c 74 2d 6c (eq? *default-l
74d0: 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 6e og-port* (curren
74e0: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 0a t-error-port))).
74f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7510: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
7520: 70 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f port *default-lo
7530: 67 2d 70 6f 72 74 2a 29 29 0a 09 09 09 20 20 20 g-port*))....
7540: 20 20 20 28 73 65 74 21 20 2a 64 65 66 61 75 6c (set! *defaul
7550: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 t-log-port* (cur
7560: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
7570: 29 29 20 22 43 6c 65 61 6e 75 70 20 64 62 20 65 )) "Cleanup db e
7580: 78 69 74 20 74 68 72 65 61 64 22 29 29 0a 09 20 xit thread"))..
7590: 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 (th2 (make-thre
75a0: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
75b0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
75c0: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
75d0: 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 og-port* "Attemp
75e0: 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e ting clean exit.
75f0: 20 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 Please be patie
7600: 6e 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 nt and wait a fe
7610: 77 20 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a 09 w seconds...")..
7620: 09 09 20 20 20 20 20 20 28 69 66 20 6e 6f 2d 68 .. (if no-h
7630: 75 72 72 79 0a 20 20 20 20 20 20 20 20 20 20 20 urry.
7640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7650: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7680: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
7690: 20 35 29 29 20 3b 3b 20 67 69 76 65 20 74 68 65 5)) ;; give the
76a0: 20 63 6c 65 61 6e 20 75 70 20 66 65 77 20 73 65 clean up few se
76b0: 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 73 conds to do it's
76c0: 20 73 74 75 66 66 0a 20 20 20 20 20 20 20 20 20 stuff.
76d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76e0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
76f0: 20 20 20 20 20 20 09 09 09 09 20 20 28 74 68 72 .... (thr
7700: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 29 29 0a ead-sleep! 2))).
7710: 20 20 20 20 20 20 09 09 09 20 20 20 20 20 20 28 ... (
7720: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
7730: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7740: 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 29 0a 20 20 " ... done").
7750: 20 20 20 20 09 09 09 20 20 20 20 20 20 29 0a 09 ... )..
7760: 09 09 20 20 20 20 22 63 6c 65 61 6e 20 65 78 69 .. "clean exi
7770: 74 22 29 29 29 0a 20 20 20 20 20 20 28 74 68 72 t"))). (thr
7780: 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a ead-start! th1).
7790: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
77a0: 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 20 art! th2).
77b0: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 (thread-join! th
77c0: 31 29 0a 20 20 20 20 20 20 29 0a 20 20 20 20 29 1). ). )
77d0: 0a 0a 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 20 .. 0)..(define
77e0: 28 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 (std-signal-hand
77f0: 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b 3b ler signum). ;;
7800: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
7810: 69 67 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 2a ignum). (set! *
7820: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
7830: 29 0a 20 20 3b 3b 28 64 65 62 75 67 3a 70 72 69 ). ;;(debug:pri
7840: 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 nt-info 13 *defa
7850: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 ult-log-port* "g
7860: 6f 74 20 73 69 67 6e 61 6c 20 22 73 69 67 6e 75 ot signal "signu
7870: 6d 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e m). (debug:prin
7880: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
7890: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 lt-log-port* "Re
78a0: 63 65 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 ceived signal "
78b0: 73 69 67 6e 75 6d 20 22 20 65 78 69 74 69 6e 67 signum " exiting
78c0: 20 70 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b promptly"). ;;
78d0: 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 (std-exit-proce
78e0: 64 75 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e dure) ;; shouldn
78f0: 27 74 20 6e 65 65 64 20 74 68 69 73 20 73 69 6e 't need this sin
7900: 63 65 20 77 65 20 61 72 65 20 65 78 69 74 69 6e ce we are exitin
7910: 67 20 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 g and it will be
7920: 20 63 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 called anyway.
7930: 20 28 65 78 69 74 29 29 0a 0a 28 73 65 74 2d 73 (exit))..(set-s
7940: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 ignal-handler! s
7950: 69 67 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 ignal/int std-s
7960: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 ignal-handler)
7970: 3b 3b 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 ;; ^C.(set-signa
7980: 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 l-handler! signa
7990: 6c 2f 74 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 l/term std-signa
79a0: 6c 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 73 l-handler).;; (s
79b0: 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 et-signal-handle
79c0: 72 21 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 r! signal/stop s
79d0: 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 td-signal-handle
79e0: 72 29 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f r) ;; ^Z NO, do
79f0: 20 4e 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a NOT handle ^Z!.
7a00: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 =========.;; M I
7a50: 20 53 20 43 20 20 20 55 20 54 20 49 20 4c 20 53 S C U T I L S
7a60: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f =========..;; co
7ab0: 6e 76 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 nvert stuff to a
7ac0: 20 6e 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 number if possi
7ad0: 62 6c 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 ble.(define (any
7ae0: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 ->number val).
7af0: 28 63 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 (cond . ((numb
7b00: 65 72 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 er? val) val).
7b10: 20 28 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 ((string? val)
7b20: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
7b30: 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f val)). ((symbo
7b40: 6c 3f 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 l? val) (any->nu
7b50: 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 mber (symbol->st
7b60: 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 ring val))). (
7b70: 65 6c 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 else #f)))..(def
7b80: 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 ine (any->number
7b90: 2d 69 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c -if-possible val
7ba0: 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 ). (let ((num (
7bb0: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 any->number val)
7bc0: 29 29 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e )). (if num n
7bd0: 75 6d 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 um val)))..(defi
7be0: 6e 65 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 ne (patt-list-ma
7bf0: 74 63 68 20 69 74 65 6d 20 70 61 74 74 73 29 0a tch item patts).
7c00: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7c10: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
7c20: 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c og-port* "patt-l
7c30: 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 ist-match item="
7c40: 20 69 74 65 6d 20 22 20 70 61 74 74 73 3d 22 20 item " patts="
7c50: 70 61 74 74 73 29 0a 20 20 28 69 66 20 28 61 6e patts). (if (an
7c60: 64 20 69 74 65 6d 20 70 61 74 74 73 29 20 20 3b d item patts) ;
7c70: 3b 20 68 65 72 65 20 77 65 20 61 72 65 20 66 69 ; here we are fi
7c80: 6c 74 65 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 ltering for matc
7c90: 68 65 73 20 77 69 74 68 20 69 74 65 6d 20 70 61 hes with item pa
7ca0: 74 74 65 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 tterns. (le
7cb0: 74 20 28 28 72 65 73 20 23 66 29 29 20 20 20 3b t ((res #f)) ;
7cc0: 3b 20 6c 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 ; look through a
7cd0: 6c 6c 20 74 68 65 20 69 74 65 6d 2d 70 61 74 74 ll the item-patt
7ce0: 73 20 69 66 20 64 65 66 69 6e 65 64 2c 20 66 6f s if defined, fo
7cf0: 72 6d 61 74 20 69 73 20 70 61 74 74 31 2c 70 61 rmat is patt1,pa
7d00: 74 74 32 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 tt2,patt3 ... wi
7d10: 6c 64 63 61 72 64 20 69 73 20 25 0a 09 28 66 6f ldcard is %..(fo
7d20: 72 2d 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 r-each .. (lambd
7d30: 61 20 28 70 61 74 74 29 0a 09 20 20 20 28 6c 65 a (patt).. (le
7d40: 74 20 28 28 6d 6f 64 70 61 74 74 20 28 73 74 72 t ((modpatt (str
7d50: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 ing-substitute "
7d60: 25 22 20 22 2e 2a 22 20 70 61 74 74 20 23 74 29 %" ".*" patt #t)
7d70: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
7d80: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 print-info 10 *d
7d90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7da0: 20 22 70 61 74 74 20 22 20 70 61 74 74 20 22 20 "patt " patt "
7db0: 6d 6f 64 70 61 74 74 20 22 20 6d 6f 64 70 61 74 modpatt " modpat
7dc0: 74 29 0a 09 20 20 20 20 20 28 69 66 20 28 73 74 t).. (if (st
7dd0: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
7de0: 78 70 20 6d 6f 64 70 61 74 74 29 20 69 74 65 6d xp modpatt) item
7df0: 29 0a 09 09 20 28 73 65 74 21 20 72 65 73 20 23 )... (set! res #
7e00: 74 29 29 29 29 0a 09 20 28 73 74 72 69 6e 67 2d t)))).. (string-
7e10: 73 70 6c 69 74 20 70 61 74 74 73 20 22 2c 22 29 split patts ",")
7e20: 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 23 74 )..res). #t
7e30: 29 29 0a 0a 3b 3b 20 27 28 70 72 69 6e 74 20 28 ))..;; '(print (
7e40: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
7e50: 73 65 20 28 6d 61 70 20 63 61 64 72 20 28 68 61 se (map cadr (ha
7e60: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7e70: 61 75 6c 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 ault (read-confi
7e80: 67 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 g "megatest.conf
7e90: 69 67 22 20 5c 23 66 20 5c 23 74 29 20 22 64 69 ig" \#f \#t) "di
7ea0: 73 6b 73 22 20 27 22 27 22 27 28 22 6e 6f 6e 65 sks" '"'"'("none
7eb0: 22 20 22 22 29 29 29 20 22 5c 6e 22 29 29 27 0a " ""))) "\n"))'.
7ec0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7ed0: 67 65 74 2d 64 69 73 6b 73 20 23 21 6b 65 79 20 get-disks #!key
7ee0: 28 63 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 (configf #f)).
7ef0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
7f00: 64 65 66 61 75 6c 74 20 0a 20 20 20 28 6f 72 20 default . (or
7f10: 63 6f 6e 66 69 67 66 20 28 72 65 61 64 2d 63 6f configf (read-co
7f20: 6e 66 69 67 20 22 6d 65 67 61 74 65 73 74 2e 63 nfig "megatest.c
7f30: 6f 6e 66 69 67 22 20 23 66 20 23 74 29 29 0a 20 onfig" #f #t)).
7f40: 20 20 22 64 69 73 6b 73 22 20 27 28 22 6e 6f 6e "disks" '("non
7f50: 65 22 20 22 22 29 29 29 0a 0a 3b 3b 20 72 65 74 e" "")))..;; ret
7f60: 75 72 6e 20 66 69 72 73 74 20 63 6f 6d 6d 61 6e urn first comman
7f70: 64 20 74 68 61 74 20 65 78 69 73 74 73 2c 20 65 d that exists, e
7f80: 6c 73 65 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e lse #f.;;.(defin
7f90: 65 20 28 63 6f 6d 6d 6f 6e 3a 77 68 69 63 68 20 e (common:which
7fa0: 63 6d 64 73 29 0a 20 20 28 69 66 20 28 6e 75 6c cmds). (if (nul
7fb0: 6c 3f 20 63 6d 64 73 29 0a 20 20 20 20 20 20 23 l? cmds). #
7fc0: 66 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f f. (let loo
7fd0: 70 20 28 28 68 65 64 20 28 63 61 72 20 63 6d 64 p ((hed (car cmd
7fe0: 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 s))... (tal (cdr
7ff0: 20 63 6d 64 73 29 29 29 0a 09 28 6c 65 74 20 28 cmds)))..(let (
8000: 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 (res (with-input
8010: 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 -from-pipe (conc
8020: 20 22 77 68 69 63 68 20 22 20 68 65 64 29 20 72 "which " hed) r
8030: 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 20 20 28 ead-line))).. (
8040: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
8050: 20 72 65 73 29 0a 09 09 20 20 20 28 63 6f 6d 6d res)... (comm
8060: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
8070: 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 res)).. res
8080: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
8090: 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 l? tal)... #f..
80a0: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
80b0: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
80c0: 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 63 )). .(define (c
80d0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c ommon:get-instal
80e0: 6c 2d 61 72 65 61 29 0a 20 20 28 6c 65 74 20 28 l-area). (let (
80f0: 28 65 78 65 2d 70 61 74 68 20 28 63 61 72 20 28 (exe-path (car (
8100: 61 72 67 76 29 29 29 29 0a 20 20 20 20 28 69 66 argv)))). (if
8110: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
8120: 69 73 74 73 3f 20 65 78 65 2d 70 61 74 68 29 0a ists? exe-path).
8130: 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
8140: 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 23 66 0a 09 ons.. exn.. #f..
8150: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
8160: 74 6f 72 79 0a 09 20 20 28 70 61 74 68 6e 61 6d tory.. (pathnam
8170: 65 2d 64 69 72 65 63 74 6f 72 79 20 0a 09 20 20 e-directory ..
8180: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
8190: 74 6f 72 79 20 65 78 65 2d 70 61 74 68 29 29 29 tory exe-path)))
81a0: 29 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 72 65 74 )..#f)))..;; ret
81b0: 75 72 6e 20 66 69 72 73 74 20 70 61 74 68 20 74 urn first path t
81c0: 68 61 74 20 63 61 6e 20 62 65 20 63 72 65 61 74 hat can be creat
81d0: 65 64 20 6f 72 20 61 6c 72 65 61 64 79 20 65 78 ed or already ex
81e0: 69 73 74 73 20 61 6e 64 20 69 73 20 77 72 69 74 ists and is writ
81f0: 61 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 able.;;.(define
8200: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 (common:get-crea
8210: 74 65 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 te-writeable-dir
8220: 20 64 69 72 73 29 0a 20 20 28 69 66 20 28 6e 75 dirs). (if (nu
8230: 6c 6c 3f 20 64 69 72 73 29 0a 20 20 20 20 20 20 ll? dirs).
8240: 23 66 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f #f. (let lo
8250: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 64 69 op ((hed (car di
8260: 72 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 rs))... (tal (cd
8270: 72 20 64 69 72 73 29 29 29 0a 09 28 6c 65 74 20 r dirs)))..(let
8280: 28 28 72 65 73 20 28 6f 72 20 28 61 6e 64 20 28 ((res (or (and (
8290: 64 69 72 65 63 74 6f 72 79 3f 20 68 65 64 29 0a directory? hed).
82a0: 09 09 09 20 20 20 20 28 66 69 6c 65 2d 77 72 69 ... (file-wri
82b0: 74 65 2d 61 63 63 65 73 73 3f 20 68 65 64 29 0a te-access? hed).
82c0: 09 09 09 20 20 20 20 68 65 64 29 0a 09 09 20 20 ... hed)...
82d0: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
82e0: 65 70 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 eptions....exn..
82f0: 09 09 23 66 0a 09 09 09 28 63 72 65 61 74 65 2d ..#f....(create-
8300: 64 69 72 65 63 74 6f 72 79 20 68 65 64 20 23 74 directory hed #t
8310: 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e ))))).. (if (an
8320: 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a d (string? res).
8330: 09 09 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f .. (directory?
8340: 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 res)).. re
8350: 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 s.. (if (nu
8360: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a ll? tal)... #f.
8370: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
8380: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
8390: 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 74 )))..;; return t
83a0: 68 65 20 79 6f 75 6e 67 65 73 74 20 74 69 6d 65 he youngest time
83b0: 73 74 61 6d 70 20 2e 20 66 69 6c 65 6e 61 6d 65 stamp . filename
83c0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
83d0: 6d 6f 6e 3a 67 65 74 2d 79 6f 75 6e 67 65 73 74 mon:get-youngest
83e0: 20 67 6c 6f 62 2d 6c 69 73 74 29 0a 20 20 28 6c glob-list). (l
83f0: 65 74 20 28 28 61 6c 6c 2d 66 69 6c 65 73 20 28 et ((all-files (
8400: 61 70 70 6c 79 20 61 70 70 65 6e 64 0a 09 09 09 apply append....
8410: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
8420: 70 61 74 74 29 0a 09 09 09 09 20 28 68 61 6e 64 patt)..... (hand
8430: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
8440: 09 09 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 .. exn.....
8450: 20 20 20 20 27 28 29 0a 09 09 09 09 20 20 20 28 '()..... (
8460: 67 6c 6f 62 20 70 61 74 74 29 29 29 0a 09 09 09 glob patt)))....
8470: 20 20 20 20 20 20 20 67 6c 6f 62 2d 6c 69 73 74 glob-list
8480: 29 29 29 29 0a 20 20 20 20 28 66 6f 6c 64 20 28 )))). (fold (
8490: 6c 61 6d 62 64 61 20 28 66 6e 61 6d 65 20 72 65 lambda (fname re
84a0: 73 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6c s).. (let ((l
84b0: 61 73 74 2d 6d 6f 64 20 28 63 61 72 20 72 65 73 ast-mod (car res
84c0: 29 29 0a 09 09 20 20 28 63 75 72 6d 6f 64 20 20 ))... (curmod
84d0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
84e0: 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 09 ons.....exn.....
84f0: 30 0a 09 09 09 20 20 20 20 20 20 28 66 69 6c 65 0.... (file
8500: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
8510: 6d 65 20 66 6e 61 6d 65 29 29 29 29 0a 09 20 20 me fname))))..
8520: 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 6d 6f (if (> curmo
8530: 64 20 6c 61 73 74 2d 6d 6f 64 29 0a 09 09 20 20 d last-mod)...
8540: 28 6c 69 73 74 20 63 75 72 6d 6f 64 20 66 6e 61 (list curmod fna
8550: 6d 65 29 0a 09 09 20 20 72 65 73 29 29 29 0a 09 me)... res)))..
8560: 20 20 27 28 30 20 22 6e 2f 61 22 29 0a 09 20 20 '(0 "n/a")..
8570: 61 6c 6c 2d 66 69 6c 65 73 29 29 29 0a 0a 3b 3b all-files)))..;;
8580: 20 75 73 65 20 62 61 73 68 20 74 6f 20 65 78 70 use bash to exp
8590: 61 6e 64 20 61 20 67 6c 6f 62 2e 20 44 6f 65 73 and a glob. Does
85a0: 20 4e 4f 54 20 68 61 6e 64 6c 65 20 70 61 74 68 NOT handle path
85b0: 73 20 77 69 74 68 20 73 70 61 63 65 73 21 0a 3b s with spaces!.;
85c0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
85d0: 6e 3a 62 61 73 68 2d 67 6c 6f 62 20 69 6e 73 74 n:bash-glob inst
85e0: 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 73 70 6c r). (string-spl
85f0: 69 74 0a 20 20 20 28 77 69 74 68 2d 69 6e 70 75 it. (with-inpu
8600: 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 t-from-pipe.
8610: 20 20 20 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 62 (conc "/bin/b
8620: 61 73 68 20 2d 63 20 5c 22 65 63 68 6f 20 22 20 ash -c \"echo "
8630: 69 6e 73 74 72 20 22 5c 22 22 29 0a 20 20 20 20 instr "\"").
8640: 20 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 20 20 read-line))).
8650: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 =========.;; T A
86a0: 20 52 20 47 20 45 20 54 20 53 20 20 2c 20 20 20 R G E T S ,
86b0: 53 20 54 20 41 20 54 20 45 20 2c 20 20 20 53 20 S T A T E , S
86c0: 54 20 41 20 54 20 55 20 53 20 2c 20 20 20 0a 3b T A T U S , .;
86d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
86e0: 20 20 20 20 20 52 20 55 20 4e 20 4e 20 41 20 4d R U N N A M
86f0: 20 45 20 20 20 20 41 20 4e 20 44 20 20 20 54 20 E A N D T
8700: 45 20 53 20 54 20 50 20 41 20 54 20 54 0a 3b 3b E S T P A T T.;;
8710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8750: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 6d 61 70 20 ======..;; (map
8760: 70 72 69 6e 74 20 28 6d 61 70 20 63 61 72 20 28 print (map car (
8770: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
8780: 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 t (read-config "
8790: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
87a0: 67 22 20 23 66 20 23 74 29 29 29 29 0a 3b 3b 0a g" #f #t)))).;;.
87b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
87c0: 67 65 74 2d 72 75 6e 63 6f 6e 66 69 67 2d 74 61 get-runconfig-ta
87d0: 72 67 65 74 73 20 23 21 6b 65 79 20 28 63 6f 6e rgets #!key (con
87e0: 66 69 67 66 20 23 66 29 29 0a 20 20 28 6c 65 74 figf #f)). (let
87f0: 20 28 28 74 61 72 67 73 20 20 20 20 20 20 20 28 ((targs (
8800: 73 6f 72 74 20 28 6d 61 70 20 63 61 72 20 28 68 sort (map car (h
8810: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
8820: 0a 09 09 09 09 20 20 20 20 20 28 6f 72 20 63 6f ..... (or co
8830: 6e 66 69 67 66 20 3b 3b 20 4e 4f 54 45 3a 20 54 nfigf ;; NOTE: T
8840: 68 65 72 65 20 69 73 20 6e 6f 20 76 61 6c 75 65 here is no value
8850: 20 69 6e 20 75 73 69 6e 67 20 72 75 6e 63 6f 6e in using runcon
8860: 66 69 67 3a 72 65 61 64 20 68 65 72 65 2e 0a 09 fig:read here...
8870: 09 09 09 09 20 28 72 65 61 64 2d 63 6f 6e 66 69 .... (read-confi
8880: 67 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 g (conc *toppath
8890: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
88a0: 6f 6e 66 69 67 22 29 0a 09 09 09 09 09 09 20 20 onfig").......
88b0: 20 20 20 20 23 66 20 23 74 29 0a 09 09 09 09 09 #f #t)......
88c0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
88d0: 65 29 29 29 29 0a 09 09 09 20 20 20 73 74 72 69 e)))).... stri
88e0: 6e 67 3c 3f 29 29 0a 09 28 74 61 72 67 65 74 2d ng<?))..(target-
88f0: 70 61 74 74 20 28 61 72 67 73 3a 67 65 74 2d 61 patt (args:get-a
8900: 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 29 0a rg "-target"))).
8910: 20 20 20 20 28 69 66 20 74 61 72 67 65 74 2d 70 (if target-p
8920: 61 74 74 0a 09 28 66 69 6c 74 65 72 20 28 6c 61 att..(filter (la
8930: 6d 62 64 61 20 28 78 29 0a 09 09 20 20 28 70 61 mbda (x)... (pa
8940: 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 78 20 tt-list-match x
8950: 74 61 72 67 65 74 2d 70 61 74 74 29 29 0a 09 09 target-patt))...
8960: 74 61 72 67 73 29 0a 09 74 61 72 67 73 29 29 29 targs)..targs)))
8970: 0a 0a 3b 3b 20 4c 6f 6f 6b 75 70 20 61 20 76 61 ..;; Lookup a va
8980: 6c 75 65 20 69 6e 20 72 75 6e 63 6f 6e 66 69 67 lue in runconfig
8990: 73 20 62 61 73 65 64 20 6f 6e 20 2d 72 65 71 74 s based on -reqt
89a0: 61 72 67 20 6f 72 20 2d 74 61 72 67 65 74 0a 3b arg or -target.;
89b0: 3b 20 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 63 ; .(define (runc
89c0: 6f 6e 66 69 67 73 2d 67 65 74 20 63 6f 6e 66 69 onfigs-get confi
89d0: 67 20 76 61 72 29 0a 20 20 28 6c 65 74 20 28 28 g var). (let ((
89e0: 74 61 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 targ (common:arg
89f0: 73 2d 67 65 74 2d 74 61 72 67 65 74 29 29 29 20 s-get-target)))
8a00: 3b 3b 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 ;; (or (args:get
8a10: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
8a20: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8a30: 74 61 72 67 65 74 22 29 28 67 65 74 65 6e 76 20 target")(getenv
8a40: 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 29 0a "MT_TARGET")))).
8a50: 20 20 20 20 28 69 66 20 74 61 72 67 0a 09 28 6f (if targ..(o
8a60: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
8a70: 70 20 63 6f 6e 66 69 67 20 74 61 72 67 20 76 61 p config targ va
8a80: 72 29 0a 09 20 20 20 20 28 63 6f 6e 66 69 67 66 r).. (configf
8a90: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
8aa0: 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 0a 09 default" var))..
8ab0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
8ac0: 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 config "default"
8ad0: 20 76 61 72 29 29 29 29 0a 0a 28 64 65 66 69 6e var))))..(defin
8ae0: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
8af0: 65 74 2d 73 74 61 74 65 29 0a 20 20 28 6f 72 20 et-state). (or
8b00: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8b10: 73 74 61 74 65 22 29 28 61 72 67 73 3a 67 65 74 state")(args:get
8b20: 2d 61 72 67 20 22 3a 73 74 61 74 65 22 29 29 29 -arg ":state")))
8b30: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
8b40: 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 75 n:args-get-statu
8b50: 73 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 s). (or (args:g
8b60: 65 74 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 et-arg "-status"
8b70: 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 )(args:get-arg "
8b80: 3a 73 74 61 74 75 73 22 29 29 29 0a 0a 28 64 65 :status")))..(de
8b90: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 fine (common:arg
8ba0: 73 2d 67 65 74 2d 74 65 73 74 70 61 74 74 20 72 s-get-testpatt r
8bb0: 63 6f 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 3b conf). (let* (;
8bc0: 3b 20 28 74 61 67 65 78 70 72 20 20 20 20 20 20 ; (tagexpr
8bd0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
8be0: 2d 74 61 67 65 78 70 72 22 29 29 0a 20 20 20 20 -tagexpr")).
8bf0: 20 20 20 20 20 3b 3b 20 28 74 61 67 73 2d 74 65 ;; (tags-te
8c00: 73 74 70 61 74 74 20 28 69 66 20 74 61 67 65 78 stpatt (if tagex
8c10: 70 72 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 pr (string-join
8c20: 28 72 75 6e 73 3a 67 65 74 2d 74 65 73 74 73 2d (runs:get-tests-
8c30: 6d 61 74 63 68 69 6e 67 2d 74 61 67 73 20 74 61 matching-tags ta
8c40: 67 65 78 70 72 29 20 22 2c 22 29 20 23 66 29 29 gexpr) ",") #f))
8c50: 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 70 . (testp
8c60: 61 74 74 2d 6b 65 79 20 20 28 69 66 20 28 61 72 att-key (if (ar
8c70: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d 6d 6f gs:get-arg "--mo
8c80: 64 65 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 depatt") (args:g
8c90: 65 74 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 et-arg "--modepa
8ca0: 74 74 22 29 20 22 54 45 53 54 50 41 54 54 22 29 tt") "TESTPATT")
8cb0: 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 67 73 ). (args
8cc0: 2d 74 65 73 74 70 61 74 74 20 28 6f 72 20 28 61 -testpatt (or (a
8cd0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 rgs:get-arg "-te
8ce0: 73 74 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 stpatt") (args:g
8cf0: 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 et-arg "-runtest
8d00: 73 22 29 20 22 25 22 29 29 0a 20 20 20 20 20 20 s") "%")).
8d10: 20 20 20 28 72 74 65 73 74 70 61 74 74 20 20 20 (rtestpatt
8d20: 20 20 28 69 66 20 72 63 6f 6e 66 20 28 72 75 6e (if rconf (run
8d30: 63 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e configs-get rcon
8d40: 66 20 74 65 73 74 70 61 74 74 2d 6b 65 79 29 20 f testpatt-key)
8d50: 23 66 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a #f))). (cond.
8d60: 20 20 20 20 20 28 28 61 72 67 73 3a 67 65 74 2d ((args:get-
8d70: 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 22 arg "--modepatt"
8d80: 29 20 3b 3b 20 6d 6f 64 65 70 61 74 74 20 69 73 ) ;; modepatt is
8d90: 20 61 20 66 6f 72 63 65 64 20 73 65 74 74 69 6e a forced settin
8da0: 67 2c 20 77 68 65 6e 20 73 65 74 20 69 74 20 4d g, when set it M
8db0: 55 53 54 20 72 65 66 65 72 20 74 6f 20 61 6e 20 UST refer to an
8dc0: 65 78 69 73 74 69 6e 67 20 50 41 54 54 20 69 6e existing PATT in
8dd0: 20 74 68 65 20 72 75 6e 63 6f 6e 66 69 67 0a 20 the runconfig.
8de0: 20 20 20 20 20 28 69 66 20 72 63 6f 6e 66 0a 09 (if rconf..
8df0: 20 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 (runconfigs-ge
8e00: 74 20 72 63 6f 6e 66 20 74 65 73 74 70 61 74 74 t rconf testpatt
8e10: 2d 6b 65 79 29 0a 09 20 20 23 66 29 29 20 20 20 -key).. #f))
8e20: 20 20 3b 3b 20 57 65 20 64 6f 20 4e 4f 54 20 66 ;; We do NOT f
8e30: 61 6c 6c 20 62 61 63 6b 20 74 6f 20 22 25 22 0a all back to "%".
8e40: 20 20 20 20 20 3b 3b 20 28 74 61 67 73 2d 74 65 ;; (tags-te
8e50: 73 74 70 61 74 74 0a 20 20 20 20 20 3b 3b 20 20 stpatt. ;;
8e60: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
8e70: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
8e80: 2d 70 6f 72 74 2a 20 22 2d 74 61 67 65 78 70 72 -port* "-tagexpr
8e90: 20 22 74 61 67 65 78 70 72 22 20 73 65 6c 65 63 "tagexpr" selec
8ea0: 74 73 20 74 65 73 74 70 61 74 74 20 22 74 61 67 ts testpatt "tag
8eb0: 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 20 20 s-testpatt).
8ec0: 20 3b 3b 20 20 74 61 67 73 2d 74 65 73 74 70 61 ;; tags-testpa
8ed0: 74 74 29 0a 20 20 20 20 20 28 28 61 6e 64 20 28 tt). ((and (
8ee0: 65 71 75 61 6c 3f 20 61 72 67 73 2d 74 65 73 74 equal? args-test
8ef0: 70 61 74 74 20 22 25 22 29 20 72 74 65 73 74 70 patt "%") rtestp
8f00: 61 74 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 att). (debu
8f10: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
8f20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
8f30: 2a 20 22 74 65 73 74 70 61 74 74 20 64 65 66 69 * "testpatt defi
8f40: 6e 65 64 20 69 6e 20 22 74 65 73 74 70 61 74 74 ned in "testpatt
8f50: 2d 6b 65 79 22 20 66 72 6f 6d 20 72 75 6e 63 6f -key" from runco
8f60: 6e 66 69 67 73 3a 20 22 20 72 74 65 73 74 70 61 nfigs: " rtestpa
8f70: 74 74 29 0a 20 20 20 20 20 20 72 74 65 73 74 70 tt). rtestp
8f80: 61 74 74 29 0a 20 20 20 20 20 28 65 6c 73 65 20 att). (else
8f90: 61 72 67 73 2d 74 65 73 74 70 61 74 74 29 29 29 args-testpatt)))
8fa0: 29 0a 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )....(define (co
8fb0: 6d 6d 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 mmon:false-on-ex
8fc0: 63 65 70 74 69 6f 6e 20 74 68 75 6e 6b 20 23 21 ception thunk #!
8fd0: 6b 65 79 20 28 6d 65 73 73 61 67 65 20 23 66 29 key (message #f)
8fe0: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
8ff0: 70 74 69 6f 6e 73 20 65 78 6e 0a 20 20 20 20 20 ptions exn.
9000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9010: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
9020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
9030: 66 20 6d 65 73 73 61 67 65 0a 20 20 20 20 20 20 f message.
9040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9050: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9060: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
9070: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6d 65 73 73 t-log-port* mess
9080: 61 67 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 age)).
9090: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
90a0: 20 28 74 68 75 6e 6b 29 20 29 29 0a 0a 28 64 65 (thunk) ))..(de
90b0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c fine (common:fil
90c0: 65 2d 65 78 69 73 74 73 3f 20 70 61 74 68 2d 73 e-exists? path-s
90d0: 74 72 69 6e 67 29 0a 20 20 3b 3b 20 74 68 69 73 tring). ;; this
90e0: 20 61 76 6f 69 64 73 20 73 74 61 63 6b 20 64 75 avoids stack du
90f0: 6d 70 73 20 69 6e 20 74 68 65 20 63 61 73 65 20 mps in the case
9100: 77 68 65 72 65 20 0a 0a 20 20 3b 3b 3b 3b 20 54 where .. ;;;; T
9110: 4f 44 4f 3a 20 63 61 74 63 68 20 70 65 72 6d 69 ODO: catch permi
9120: 73 73 69 6f 6e 20 64 65 6e 69 65 64 20 65 78 63 ssion denied exc
9130: 65 70 74 69 6f 6e 73 20 61 6e 64 20 65 6d 69 74 eptions and emit
9140: 20 61 70 70 72 6f 70 72 69 61 74 65 20 77 61 72 appropriate war
9150: 6e 69 6e 67 73 2c 20 65 67 3a 20 20 73 79 73 74 nings, eg: syst
9160: 65 6d 20 65 72 72 6f 72 20 77 68 69 6c 65 20 74 em error while t
9170: 72 79 69 6e 67 20 74 6f 20 61 63 63 65 73 73 20 rying to access
9180: 66 69 6c 65 3a 20 22 2f 6e 66 73 2f 70 64 78 2f file: "/nfs/pdx/
9190: 64 69 73 6b 73 2f 69 63 66 5f 65 6e 76 5f 64 69 disks/icf_env_di
91a0: 73 6b 30 30 31 2f 62 6a 62 61 72 63 6c 61 2f 67 sk001/bjbarcla/g
91b0: 77 61 2f 69 73 73 75 65 73 2f 6d 74 64 65 76 2f wa/issues/mtdev/
91c0: 72 61 6e 64 79 2d 73 6c 6f 77 2f 72 65 70 72 6f randy-slow/repro
91d0: 64 75 63 65 2f 71 2e 2e 2e 0a 20 20 28 63 6f 6d duce/q.... (com
91e0: 6d 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 63 mon:false-on-exc
91f0: 65 70 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 eption (lambda (
9200: 29 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 ) (file-exists?
9210: 70 61 74 68 2d 73 74 72 69 6e 67 29 29 0a 20 20 path-string)).
9220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9230: 20 20 20 20 20 20 20 20 20 20 20 6d 65 73 73 61 messa
9240: 67 65 3a 20 28 63 6f 6e 63 20 22 55 6e 61 62 6c ge: (conc "Unabl
9250: 65 20 74 6f 20 61 63 63 65 73 73 20 70 61 74 68 e to access path
9260: 3a 20 22 20 70 61 74 68 2d 73 74 72 69 6e 67 29 : " path-string)
9270: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
9290: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
92a0: 6e 3a 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 n:directory-exis
92b0: 74 73 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 29 ts? path-string)
92c0: 0a 20 20 3b 3b 3b 3b 20 54 4f 44 4f 3a 20 63 61 . ;;;; TODO: ca
92d0: 74 63 68 20 70 65 72 6d 69 73 73 69 6f 6e 20 64 tch permission d
92e0: 65 6e 69 65 64 20 65 78 63 65 70 74 69 6f 6e 73 enied exceptions
92f0: 20 61 6e 64 20 65 6d 69 74 20 61 70 70 72 6f 70 and emit approp
9300: 72 69 61 74 65 20 77 61 72 6e 69 6e 67 73 2c 20 riate warnings,
9310: 65 67 3a 20 20 73 79 73 74 65 6d 20 65 72 72 6f eg: system erro
9320: 72 20 77 68 69 6c 65 20 74 72 79 69 6e 67 20 74 r while trying t
9330: 6f 20 61 63 63 65 73 73 20 66 69 6c 65 3a 20 22 o access file: "
9340: 2f 6e 66 73 2f 70 64 78 2f 64 69 73 6b 73 2f 69 /nfs/pdx/disks/i
9350: 63 66 5f 65 6e 76 5f 64 69 73 6b 30 30 31 2f 62 cf_env_disk001/b
9360: 6a 62 61 72 63 6c 61 2f 67 77 61 2f 69 73 73 75 jbarcla/gwa/issu
9370: 65 73 2f 6d 74 64 65 76 2f 72 61 6e 64 79 2d 73 es/mtdev/randy-s
9380: 6c 6f 77 2f 72 65 70 72 6f 64 75 63 65 2f 71 2e low/reproduce/q.
9390: 2e 2e 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 6c ... (common:fal
93a0: 73 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 20 se-on-exception
93b0: 28 6c 61 6d 62 64 61 20 28 29 20 28 64 69 72 65 (lambda () (dire
93c0: 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 ctory-exists? pa
93d0: 74 68 2d 73 74 72 69 6e 67 29 29 0a 20 20 20 20 th-string)).
93e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
93f0: 20 20 20 20 20 20 20 20 20 6d 65 73 73 61 67 65 message
9400: 3a 20 28 63 6f 6e 63 20 22 55 6e 61 62 6c 65 20 : (conc "Unable
9410: 74 6f 20 61 63 63 65 73 73 20 70 61 74 68 3a 20 to access path:
9420: 22 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a 20 " path-string).
9430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9440: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 0a 0a ))..
9450: 3b 3b 20 64 6f 65 73 20 74 68 65 20 64 69 72 65 ;; does the dire
9460: 63 74 6f 72 79 20 65 78 69 73 74 20 61 6e 64 20 ctory exist and
9470: 64 6f 20 77 65 20 68 61 76 65 20 77 72 69 74 65 do we have write
9480: 20 61 63 63 65 73 73 3f 0a 3b 3b 0a 3b 3b 20 20 access?.;;.;;
9490: 20 20 72 65 74 75 72 6e 73 20 74 68 65 20 64 69 returns the di
94a0: 72 65 63 74 6f 72 79 20 6f 72 20 23 66 0a 3b 3b rectory or #f.;;
94b0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
94c0: 3a 64 69 72 65 63 74 6f 72 79 2d 77 72 69 74 61 :directory-writa
94d0: 62 6c 65 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 ble? path-string
94e0: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
94f0: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
9500: 20 23 66 0a 20 20 20 28 69 66 20 28 61 6e 64 20 #f. (if (and
9510: 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 (directory-exist
9520: 73 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a s? path-string).
9530: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c (fil
9540: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
9550: 70 61 74 68 2d 73 74 72 69 6e 67 29 29 0a 20 20 path-string)).
9560: 20 20 20 20 20 70 61 74 68 2d 73 74 72 69 6e 67 path-string
9570: 0a 20 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 . #f)))..(
9580: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
9590: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 et-linktree). (
95a0: 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c or (getenv "MT_L
95b0: 49 4e 4b 54 52 45 45 22 29 0a 20 20 20 20 20 20 INKTREE").
95c0: 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a (if *configdat*.
95d0: 09 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b . (configf:look
95e0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
95f0: 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 setup" "linktree
9600: 22 29 0a 09 20 20 28 69 66 20 2a 74 6f 70 70 61 ").. (if *toppa
9610: 74 68 2a 0a 09 20 20 20 20 20 20 28 63 6f 6e 63 th*.. (conc
9620: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 6c 74 22 *toppath* "/lt"
9630: 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 0a ).. #f)))).
9640: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
9650: 3a 61 72 67 73 2d 67 65 74 2d 72 75 6e 6e 61 6d :args-get-runnam
9660: 65 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 e). (let ((res
9670: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
9680: 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 g "-runname")...
9690: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
96a0: 3a 72 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 67 :runname")... (g
96b0: 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d etenv "MT_RUNNAM
96c0: 45 22 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 69 E")))). ;; (i
96d0: 66 20 72 65 73 20 28 73 65 74 2d 65 6e 76 69 72 f res (set-envir
96e0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
96f0: 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 72 65 73 "MT_RUNNAME" res
9700: 29 29 20 3b 3b 20 6e 6f 74 20 73 75 72 65 20 69 )) ;; not sure i
9710: 66 20 74 68 69 73 20 69 73 20 61 20 67 6f 6f 64 f this is a good
9720: 20 69 64 65 61 2e 20 73 69 64 65 20 65 66 66 65 idea. side effe
9730: 63 74 20 61 6e 64 20 61 6c 6c 20 2e 2e 2e 0a 20 ct and all ....
9740: 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e res))..(defin
9750: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 69 e (common:get-fi
9760: 65 6c 64 73 20 63 66 67 64 61 74 29 0a 20 20 28 elds cfgdat). (
9770: 6c 65 74 20 28 28 66 69 65 6c 64 73 20 28 68 61 let ((fields (ha
9780: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
9790: 61 75 6c 74 20 63 66 67 64 61 74 20 22 66 69 65 ault cfgdat "fie
97a0: 6c 64 73 22 20 27 28 29 29 29 29 0a 20 20 20 20 lds" '()))).
97b0: 28 6d 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 (map car fields)
97c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
97d0: 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 mon:args-get-tar
97e0: 67 65 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 get #!key (split
97f0: 20 23 66 29 28 65 78 69 74 2d 69 66 2d 62 61 64 #f)(exit-if-bad
9800: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
9810: 6b 65 79 73 20 20 20 20 28 69 66 20 28 68 61 73 keys (if (has
9820: 68 2d 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 h-table? *config
9830: 64 61 74 2a 29 20 28 63 6f 6d 6d 6f 6e 3a 67 65 dat*) (common:ge
9840: 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 t-fields *config
9850: 64 61 74 2a 29 20 27 28 29 29 29 0a 09 20 28 6e dat*) '())).. (n
9860: 75 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 6b umkeys (length k
9870: 65 79 73 29 29 0a 09 20 28 74 61 72 67 65 74 20 eys)).. (target
9880: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
9890: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 rg "-reqtarg")..
98a0: 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 . (args:get
98b0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
98c0: 09 09 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 .. (getenv
98d0: 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 "MT_TARGET")))..
98e0: 20 28 74 6c 69 73 74 20 20 20 28 69 66 20 74 61 (tlist (if ta
98f0: 72 67 65 74 20 28 73 74 72 69 6e 67 2d 73 70 6c rget (string-spl
9900: 69 74 20 74 61 72 67 65 74 20 22 2f 22 20 23 74 it target "/" #t
9910: 29 20 27 28 29 29 29 0a 09 20 28 76 61 6c 69 64 ) '())).. (valid
9920: 20 20 20 28 69 66 20 74 61 72 67 65 74 0a 09 09 (if target...
9930: 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f (or (null?
9940: 20 6b 65 79 73 29 20 3b 3b 20 70 72 6f 62 61 62 keys) ;; probab
9950: 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 ly don't know ou
9960: 72 20 6b 65 79 73 20 79 65 74 0a 09 09 09 20 20 r keys yet....
9970: 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
9980: 20 74 6c 69 73 74 29 29 0a 09 09 09 20 20 20 20 tlist))....
9990: 20 20 20 28 65 71 3f 20 6e 75 6d 6b 65 79 73 20 (eq? numkeys
99a0: 28 6c 65 6e 67 74 68 20 74 6c 69 73 74 29 29 0a (length tlist)).
99b0: 09 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f ... (null?
99c0: 20 28 66 69 6c 74 65 72 20 73 74 72 69 6e 67 2d (filter string-
99d0: 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 29 29 0a null? tlist)))).
99e0: 09 09 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 .. #f))).
99f0: 20 20 28 69 66 20 76 61 6c 69 64 0a 09 28 69 66 (if valid..(if
9a00: 20 73 70 6c 69 74 0a 09 20 20 20 20 74 6c 69 73 split.. tlis
9a10: 74 0a 09 20 20 20 20 74 61 72 67 65 74 29 0a 09 t.. target)..
9a20: 28 69 66 20 74 61 72 67 65 74 0a 09 20 20 20 20 (if target..
9a30: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
9a40: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
9a50: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
9a60: 70 6f 72 74 2a 20 22 49 6e 76 61 6c 69 64 20 74 port* "Invalid t
9a70: 61 72 67 65 74 2c 20 73 70 61 63 65 73 20 6f 72 arget, spaces or
9a80: 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f blanks not allo
9a90: 77 65 64 20 5c 22 22 20 74 61 72 67 65 74 20 22 wed \"" target "
9aa0: 5c 22 2c 20 74 61 72 67 65 74 20 73 68 6f 75 6c \", target shoul
9ab0: 64 20 62 65 3a 20 22 20 28 73 74 72 69 6e 67 2d d be: " (string-
9ac0: 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 73 intersperse keys
9ad0: 20 22 2f 22 29 20 22 2c 20 68 61 76 65 20 22 20 "/") ", have "
9ae0: 74 6c 69 73 74 20 22 20 66 6f 72 20 65 6c 65 6d tlist " for elem
9af0: 65 6e 74 73 22 29 0a 09 20 20 20 20 20 20 28 69 ents").. (i
9b00: 66 20 65 78 69 74 2d 69 66 2d 62 61 64 20 28 65 f exit-if-bad (e
9b10: 78 69 74 20 31 29 29 0a 09 20 20 20 20 20 20 23 xit 1)).. #
9b20: 66 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a f).. #f))))..
9b30: 3b 3b 20 6c 6f 6f 6b 69 6e 67 20 6f 6e 6c 79 20 ;; looking only
9b40: 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 6e 6f (at least for no
9b50: 77 29 20 61 74 20 74 68 65 20 4d 54 5f 20 76 61 w) at the MT_ va
9b60: 72 69 61 62 6c 65 73 20 63 72 61 66 74 20 74 68 riables craft th
9b70: 65 20 66 75 6c 6c 20 74 65 73 74 6e 61 6d 65 0a e full testname.
9b80: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
9b90: 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d 74 65 73 74 on:get-full-test
9ba0: 2d 6e 61 6d 65 29 0a 20 20 28 69 66 20 28 67 65 -name). (if (ge
9bb0: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
9bc0: 4d 45 22 29 0a 20 20 20 20 20 20 28 69 66 20 28 ME"). (if (
9bd0: 61 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f and (getenv "MT_
9be0: 49 54 45 4d 50 41 54 48 22 29 0a 20 20 20 20 20 ITEMPATH").
9bf0: 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 (not (
9c00: 65 71 75 61 6c 3f 20 28 67 65 74 65 6e 76 20 22 equal? (getenv "
9c10: 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 20 22 22 MT_ITEMPATH") ""
9c20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 67 ))). (g
9c30: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
9c40: 41 4d 45 22 29 0a 20 20 20 20 20 20 20 20 20 20 AME").
9c50: 28 63 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 4d (conc (getenv "M
9c60: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 20 22 2f T_TEST_NAME") "/
9c70: 22 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 " (getenv "MT_IT
9c80: 45 4d 50 41 54 48 22 29 29 29 0a 20 20 20 20 20 EMPATH"))).
9c90: 20 23 66 29 29 0a 0a 3b 3b 20 6c 6f 67 69 63 20 #f))..;; logic
9ca0: 66 6f 72 20 67 65 74 74 69 6e 67 20 68 6f 6d 65 for getting home
9cb0: 68 6f 73 74 2e 20 52 65 74 75 72 6e 73 20 28 68 host. Returns (h
9cc0: 6f 73 74 20 2e 20 61 74 2d 68 6f 6d 65 29 0a 3b ost . at-home).;
9cd0: 3b 20 49 46 20 2a 74 6f 70 70 61 74 68 2a 20 69 ; IF *toppath* i
9ce0: 73 20 6e 6f 74 20 73 65 74 2c 20 77 61 69 74 20 s not set, wait
9cf0: 75 70 20 74 6f 20 66 69 76 65 20 73 65 63 6f 6e up to five secon
9d00: 64 73 20 74 72 79 69 6e 67 20 65 76 65 72 79 20 ds trying every
9d10: 74 77 6f 20 73 65 63 6f 6e 64 73 0a 3b 3b 20 28 two seconds.;; (
9d20: 74 68 69 73 20 69 73 20 74 6f 20 61 63 63 6f 6d this is to accom
9d30: 6f 64 61 74 65 20 74 68 65 20 77 61 74 63 68 64 odate the watchd
9d40: 6f 67 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 og).;;.(define (
9d50: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 common:get-homeh
9d60: 6f 73 74 20 23 21 6b 65 79 20 28 74 72 79 6e 75 ost #!key (trynu
9d70: 6d 20 35 29 29 0a 20 20 3b 3b 20 63 61 6c 6c 65 m 5)). ;; calle
9d80: 64 20 6f 66 74 65 6e 20 65 73 70 65 63 69 61 6c d often especial
9d90: 6c 79 20 61 74 20 73 74 61 72 74 20 75 70 2e 20 ly at start up.
9da0: 75 73 65 20 6d 75 74 65 78 20 74 6f 20 65 6c 69 use mutex to eli
9db0: 6d 69 6e 61 74 65 20 63 6f 6c 6c 69 73 69 6f 6e minate collision
9dc0: 73 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 s. (mutex-lock!
9dd0: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
9de0: 2a 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 2a *). (cond. (*
9df0: 68 6f 6d 65 2d 68 6f 73 74 2a 0a 20 20 20 20 28 home-host*. (
9e00: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
9e10: 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a omehost-mutex*).
9e20: 20 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 *home-host*)
9e30: 0a 20 20 20 28 28 6e 6f 74 20 2a 74 6f 70 70 61 . ((not *toppa
9e40: 74 68 2a 29 0a 20 20 20 20 28 6d 75 74 65 78 2d th*). (mutex-
9e50: 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 unlock! *homehos
9e60: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 6c t-mutex*). (l
9e70: 61 75 6e 63 68 3a 73 65 74 75 70 29 20 3b 3b 20 aunch:setup) ;;
9e80: 73 61 66 65 6c 79 20 6d 75 74 65 78 65 64 20 6e safely mutexed n
9e90: 6f 77 0a 20 20 20 20 28 69 66 20 28 3e 20 74 72 ow. (if (> tr
9ea0: 79 6e 75 6d 20 30 29 0a 09 28 62 65 67 69 6e 0a ynum 0)..(begin.
9eb0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
9ec0: 21 20 32 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a ! 2).. (common:
9ed0: 67 65 74 2d 68 6f 6d 65 68 6f 73 74 20 74 72 79 get-homehost try
9ee0: 6e 75 6d 3a 20 28 2d 20 74 72 79 6e 75 6d 20 31 num: (- trynum 1
9ef0: 29 29 29 0a 09 23 66 29 29 0a 20 20 20 28 65 6c )))..#f)). (el
9f00: 73 65 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 63 se. (let* ((c
9f10: 75 72 72 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 urrhost (get-hos
9f20: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 28 62 65 t-name)).. (be
9f30: 73 74 61 64 72 73 20 28 73 65 72 76 65 72 3a 67 stadrs (server:g
9f40: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
9f50: 64 72 65 73 73 20 63 75 72 72 68 6f 73 74 29 29 dress currhost))
9f60: 0a 09 20 20 20 3b 3b 20 66 69 72 73 74 20 6c 6f .. ;; first lo
9f70: 6f 6b 20 69 6e 20 63 6f 6e 66 69 67 2c 20 74 68 ok in config, th
9f80: 65 6e 20 6c 6f 6f 6b 20 69 6e 20 66 69 6c 65 20 en look in file
9f90: 2e 68 6f 6d 65 68 6f 73 74 2c 20 63 72 65 61 74 .homehost, creat
9fa0: 65 20 69 74 20 69 66 20 6e 6f 74 20 66 6f 75 6e e it if not foun
9fb0: 64 0a 09 20 20 20 28 68 6f 6d 65 68 6f 73 74 20 d.. (homehost
9fc0: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
9fd0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
9fe0: 22 73 65 72 76 65 72 22 20 22 68 6f 6d 65 68 6f "server" "homeho
9ff0: 73 74 22 20 29 0a 09 09 09 20 28 68 61 6e 64 6c st" ).... (handl
a000: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
a010: 20 20 20 20 20 65 78 6e 0a 09 09 09 20 20 20 20 exn....
a020: 20 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 30 (if (> trynum 0
a030: 29 0a 09 09 09 09 20 28 6c 65 74 20 28 28 64 65 )..... (let ((de
a040: 6c 61 79 2d 74 69 6d 65 20 28 2a 20 28 2d 20 35 lay-time (* (- 5
a050: 20 74 72 79 6e 75 6d 29 20 35 29 29 29 0a 09 09 trynum) 5)))...
a060: 09 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f .. (mutex-unlo
a070: 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 ck! *homehost-mu
a080: 74 65 78 2a 29 0a 09 09 09 09 20 20 20 28 64 65 tex*)..... (de
a090: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
a0a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a0b0: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
a0c0: 20 72 65 61 64 20 2e 68 6f 6d 65 68 6f 73 74 20 read .homehost
a0d0: 66 69 6c 65 2c 20 64 65 6c 61 79 69 6e 67 20 22 file, delaying "
a0e0: 20 64 65 6c 61 79 2d 74 69 6d 65 20 22 20 73 65 delay-time " se
a0f0: 63 6f 6e 64 73 20 61 6e 64 20 74 72 79 69 6e 67 conds and trying
a100: 20 61 67 61 69 6e 2c 20 6d 65 73 73 61 67 65 3a again, message:
a110: 20 22 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d " ((condition-
a120: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
a130: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
a140: 20 65 78 6e 29 29 0a 09 09 09 09 20 20 20 28 74 exn))..... (t
a150: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 64 65 6c hread-sleep! del
a160: 61 79 2d 74 69 6d 65 29 0a 09 09 09 09 20 20 20 ay-time).....
a170: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
a180: 68 6f 73 74 20 74 72 79 6e 75 6d 3a 20 28 2d 20 host trynum: (-
a190: 74 72 79 6e 75 6d 20 31 29 29 29 0a 09 09 09 09 trynum 1))).....
a1a0: 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 28 (begin..... (
a1b0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
a1c0: 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a omehost-mutex*).
a1d0: 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
a1e0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
a1f0: 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
a200: 20 46 61 69 6c 65 64 20 74 6f 20 72 65 61 64 20 Failed to read
a210: 2e 68 6f 6d 65 68 6f 73 74 20 66 69 6c 65 20 61 .homehost file a
a220: 66 74 65 72 20 74 72 79 69 6e 67 20 66 69 76 65 fter trying five
a230: 20 74 69 6d 65 73 2e 20 47 69 76 69 6e 67 20 75 times. Giving u
a240: 70 20 61 6e 64 20 65 78 69 74 69 6e 67 2c 20 6d p and exiting, m
a250: 65 73 73 61 67 65 3a 20 22 20 20 28 28 63 6f 6e essage: " ((con
a260: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
a270: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
a280: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 essage) exn))...
a290: 09 09 20 20 20 28 65 78 69 74 20 31 29 29 29 0a .. (exit 1))).
a2a0: 09 09 09 20 20 20 28 6c 65 74 20 28 28 68 68 66 ... (let ((hhf
a2b0: 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
a2c0: 20 22 2f 2e 68 6f 6d 65 68 6f 73 74 22 29 29 29 "/.homehost")))
a2d0: 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 63 6f .... (if (co
a2e0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
a2f0: 3f 20 68 68 66 29 0a 09 09 09 09 20 28 77 69 74 ? hhf)..... (wit
a300: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
a310: 65 20 68 68 66 20 72 65 61 64 2d 6c 69 6e 65 29 e hhf read-line)
a320: 0a 09 09 09 09 20 28 69 66 20 28 66 69 6c 65 2d ..... (if (file-
a330: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 write-access? *t
a340: 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 20 20 20 oppath*).....
a350: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
a360: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
a370: 2d 74 6f 2d 66 69 6c 65 20 68 68 66 0a 09 09 09 -to-file hhf....
a380: 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 .. (lambda ()...
a390: 09 09 09 20 20 20 28 70 72 69 6e 74 20 62 65 73 ... (print bes
a3a0: 74 61 64 72 73 29 29 29 0a 09 09 09 09 20 20 20 tadrs))).....
a3b0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 (begin......
a3c0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
a3d0: 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a *homehost-mutex*
a3e0: 29 0a 09 09 09 09 09 20 28 63 61 72 20 28 63 6f )...... (car (co
a3f0: 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 mmon:get-homehos
a400: 74 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 23 t))))..... #
a410: 66 29 29 29 29 29 29 0a 09 20 20 20 28 61 74 2d f)))))).. (at-
a420: 68 6f 6d 65 20 20 28 6f 72 20 28 65 71 75 61 6c home (or (equal
a430: 3f 20 68 6f 6d 65 68 6f 73 74 20 63 75 72 72 68 ? homehost currh
a440: 6f 73 74 29 0a 09 09 09 20 28 65 71 75 61 6c 3f ost).... (equal?
a450: 20 68 6f 6d 65 68 6f 73 74 20 62 65 73 74 61 64 homehost bestad
a460: 72 73 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 rs)))). (se
a470: 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 28 t! *home-host* (
a480: 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 74 20 61 74 cons homehost at
a490: 2d 68 6f 6d 65 29 29 0a 20 20 20 20 20 20 28 6d -home)). (m
a4a0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f utex-unlock! *ho
a4b0: 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 mehost-mutex*).
a4c0: 20 20 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a *home-host*
a4d0: 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 49 20 6f 6e ))))..;; am I on
a4e0: 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 3f 0a 3b the homehost?.;
a4f0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
a500: 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a n:on-homehost?).
a510: 20 20 28 6c 65 74 20 28 28 68 68 20 28 63 6f 6d (let ((hh (com
a520: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
a530: 29 29 29 0a 20 20 20 20 28 69 66 20 68 68 0a 09 ))). (if hh..
a540: 28 63 64 72 20 68 68 29 0a 09 23 66 29 29 29 0a (cdr hh)..#f))).
a550: 0a 3b 3b 20 64 6f 20 77 65 20 68 6f 6e 6f 72 20 .;; do we honor
a560: 74 68 65 20 63 61 63 68 65 73 20 6f 66 20 74 68 the caches of th
a570: 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 73 3f 0a e config files?.
a580: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
a590: 6f 6e 3a 75 73 65 2d 63 61 63 68 65 3f 29 0a 20 on:use-cache?).
a5a0: 20 28 6c 65 74 20 28 28 72 65 73 20 23 74 29 29 (let ((res #t))
a5b0: 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 62 79 20 ;; priority by
a5c0: 6f 72 64 65 72 20 6f 66 20 65 76 61 6c 75 61 74 order of evaluat
a5d0: 69 6f 6e 0a 20 20 20 20 28 69 66 20 2a 63 6f 6e ion. (if *con
a5e0: 66 69 67 64 61 74 2a 20 3b 3b 20 73 69 6c 6c 79 figdat* ;; silly
a5f0: 6e 65 73 73 20 68 65 72 65 2e 20 63 61 6e 27 74 ness here. can't
a600: 20 75 73 65 20 73 65 74 75 70 2f 75 73 65 2d 63 use setup/use-c
a610: 61 63 68 65 20 74 6f 20 6b 6e 6f 77 20 69 66 20 ache to know if
a620: 77 65 20 63 61 6e 20 75 73 65 20 74 68 65 20 63 we can use the c
a630: 61 63 68 65 64 20 66 69 6c 65 73 21 0a 09 28 69 ached files!..(i
a640: 66 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 f (equal? (confi
a650: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
a660: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 75 gdat* "setup" "u
a670: 73 65 2d 63 61 63 68 65 22 29 20 22 6e 6f 22 29 se-cache") "no")
a680: 0a 09 20 20 20 20 28 73 65 74 21 20 72 65 73 20 .. (set! res
a690: 23 66 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 #f).. (if (eq
a6a0: 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ual? (configf:lo
a6b0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
a6c0: 20 22 73 65 74 75 70 22 20 22 75 73 65 2d 63 61 "setup" "use-ca
a6d0: 63 68 65 22 29 20 22 79 65 73 22 29 0a 09 09 28 che") "yes")...(
a6e0: 73 65 74 21 20 72 65 73 20 23 74 29 29 29 29 0a set! res #t)))).
a6f0: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
a700: 74 2d 61 72 67 20 22 2d 6e 6f 2d 63 61 63 68 65 t-arg "-no-cache
a710: 22 29 28 73 65 74 21 20 72 65 73 20 23 66 29 29 ")(set! res #f))
a720: 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 73 65 ;; overrides se
a730: 74 74 69 6e 67 20 69 6e 20 22 73 65 74 75 70 22 tting in "setup"
a740: 0a 20 20 20 20 28 69 66 20 28 67 65 74 65 6e 76 . (if (getenv
a750: 20 22 4d 54 5f 55 53 45 5f 43 41 43 48 45 22 29 "MT_USE_CACHE")
a760: 0a 09 28 69 66 20 28 65 71 75 61 6c 3f 20 28 67 ..(if (equal? (g
a770: 65 74 65 6e 76 20 22 4d 54 5f 55 53 45 5f 43 41 etenv "MT_USE_CA
a780: 43 48 45 22 29 20 22 79 65 73 22 29 0a 09 20 20 CHE") "yes")..
a790: 20 20 28 73 65 74 21 20 72 65 73 20 23 74 29 0a (set! res #t).
a7a0: 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
a7b0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 55 53 45 (getenv "MT_USE
a7c0: 5f 43 41 43 48 45 22 29 20 22 6e 6f 22 29 0a 09 _CACHE") "no")..
a7d0: 09 28 73 65 74 21 20 72 65 73 20 23 66 29 29 29 .(set! res #f)))
a7e0: 29 20 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 ) ;; override
a7f0: 73 20 2d 6e 6f 2d 63 61 63 68 65 20 73 77 69 74 s -no-cache swit
a800: 63 68 0a 20 20 20 20 72 65 73 29 29 0a 20 20 0a ch. res)). .
a810: 3b 3b 20 66 6f 72 63 65 20 75 73 65 20 6f 66 20 ;; force use of
a820: 73 65 72 76 65 72 3f 0a 3b 3b 0a 28 64 65 66 69 server?.;;.(defi
a830: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 ne (common:force
a840: 2d 73 65 72 76 65 72 3f 29 0a 20 20 28 6c 65 74 -server?). (let
a850: 2a 20 28 28 66 6f 72 63 65 2d 73 65 74 74 69 6e * ((force-settin
a860: 67 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 g (configf:looku
a870: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
a880: 65 72 76 65 72 22 20 22 66 6f 72 63 65 22 29 29 erver" "force"))
a890: 0a 09 20 28 66 6f 72 63 65 2d 74 79 70 65 20 20 .. (force-type
a8a0: 20 20 28 69 66 20 66 6f 72 63 65 2d 73 65 74 74 (if force-sett
a8b0: 69 6e 67 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ing (string->sym
a8c0: 62 6f 6c 20 66 6f 72 63 65 2d 73 65 74 74 69 6e bol force-settin
a8d0: 67 29 20 23 66 29 29 0a 09 20 28 66 6f 72 63 65 g) #f)).. (force
a8e0: 2d 72 65 73 75 6c 74 20 20 28 63 61 73 65 20 66 -result (case f
a8f0: 6f 72 63 65 2d 74 79 70 65 0a 09 09 09 20 20 28 orce-type.... (
a900: 28 23 66 29 20 20 20 20 20 23 66 29 0a 09 09 09 (#f) #f)....
a910: 20 20 28 28 61 6c 77 61 79 73 29 20 23 74 29 0a ((always) #t).
a920: 09 09 09 20 20 28 28 74 65 73 74 29 20 20 20 28 ... ((test) (
a930: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
a940: 20 22 2d 65 78 65 63 75 74 65 22 29 20 3b 3b 20 "-execute") ;;
a950: 77 65 20 61 72 65 20 69 6e 20 61 20 74 65 73 74 we are in a test
a960: 0a 09 09 09 09 09 23 74 0a 09 09 09 09 09 23 66 ......#t......#f
a970: 29 29 0a 09 09 09 20 20 28 65 6c 73 65 0a 09 09 )).... (else...
a980: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
a990: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
a9a0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 42 61 port* "ERROR: Ba
a9b0: 64 20 73 65 72 76 65 72 20 66 6f 72 63 65 20 73 d server force s
a9c0: 65 74 74 69 6e 67 20 22 20 66 6f 72 63 65 2d 73 etting " force-s
a9d0: 65 74 74 69 6e 67 20 22 2c 20 66 6f 72 63 69 6e etting ", forcin
a9e0: 67 20 73 65 72 76 65 72 2e 22 29 0a 09 09 09 20 g server.")....
a9f0: 20 20 23 74 29 29 29 29 20 3b 3b 20 64 65 66 61 #t)))) ;; defa
aa00: 75 6c 74 20 74 6f 20 72 65 71 75 69 72 69 6e 67 ult to requiring
aa10: 20 73 65 72 76 65 72 0a 20 20 20 20 28 69 66 20 server. (if
aa20: 66 6f 72 63 65 2d 72 65 73 75 6c 74 0a 09 28 62 force-result..(b
aa30: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
aa40: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
aa50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
aa60: 66 6f 72 63 69 6e 67 20 75 73 65 20 6f 66 20 73 forcing use of s
aa70: 65 72 76 65 72 2c 20 66 6f 72 63 65 20 73 65 74 erver, force set
aa80: 74 69 6e 67 20 69 73 20 5c 22 22 20 66 6f 72 63 ting is \"" forc
aa90: 65 2d 73 65 74 74 69 6e 67 20 22 5c 22 2e 22 29 e-setting "\".")
aaa0: 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a .. #t)..#f)))..
aab0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
aac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aaf0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 ========.;; M I
ab00: 53 20 43 20 20 20 4c 20 49 20 53 20 54 20 53 0a S C L I S T S.
ab10: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
ab20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab50: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 65 ========..;; ite
ab60: 6d 73 20 69 6e 20 6c 69 73 74 61 20 61 72 65 20 ms in lista are
ab70: 6d 61 74 63 68 65 64 20 76 61 6c 75 65 20 61 6e matched value an
ab80: 64 20 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c 69 d position in li
ab90: 73 74 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 68 stb.;; return th
aba0: 65 20 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 6d e remaining item
abb0: 73 20 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 66 s in listb or #f
abc0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
abd0: 6d 6f 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 6c mon:list-is-subl
abe0: 69 73 74 20 6c 69 73 74 61 20 6c 69 73 74 62 29 ist lista listb)
abf0: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 69 . (if (null? li
ac00: 73 74 61 29 0a 20 20 20 20 20 20 6c 69 73 74 62 sta). listb
ac10: 20 3b 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 6e ;; all items in
ac20: 20 6c 69 73 74 62 20 61 72 65 20 22 72 65 6d 61 listb are "rema
ac30: 69 6e 69 6e 67 22 0a 20 20 20 20 20 20 28 69 66 ining". (if
ac40: 20 28 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 74 (> (length list
ac50: 61 29 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 29 a)(length listb)
ac60: 29 20 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 74 ) .. #f.. (let
ac70: 20 6c 6f 6f 70 20 28 28 68 65 64 61 20 28 63 61 loop ((heda (ca
ac80: 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 r lista))...
ac90: 20 28 74 61 6c 61 20 28 63 64 72 20 6c 69 73 74 (tala (cdr list
aca0: 61 29 29 0a 09 09 20 20 20 20 20 28 68 65 64 62 a))... (hedb
acb0: 20 28 63 61 72 20 6c 69 73 74 62 29 29 0a 09 09 (car listb))...
acc0: 20 20 20 20 20 28 74 61 6c 62 20 28 63 64 72 20 (talb (cdr
acd0: 6c 69 73 74 62 29 29 29 0a 09 20 20 20 20 28 69 listb))).. (i
ace0: 66 20 28 65 71 75 61 6c 3f 20 68 65 64 61 20 68 f (equal? heda h
acf0: 65 64 62 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c edb)...(if (null
ad00: 3f 20 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 72 ? tala) ;; we ar
ad10: 65 20 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 6c e done... tal
ad20: 62 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 b... (loop (c
ad30: 61 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 ar tala).... (c
ad40: 64 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 dr tala).... (c
ad50: 61 72 20 74 61 6c 62 29 0a 09 09 09 20 20 0a 09 ar talb).... ..
ad60: 09 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 29 .. (cdr talb)))
ad70: 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 4e ...#f)))))..;; N
ad80: 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 6c eeded for long l
ad90: 69 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 65 ists to be sorte
ada0: 64 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 6d d where (apply m
adb0: 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b 3b ax ... ) dies.;;
adc0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
add0: 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 6c :max inlst). (l
ade0: 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 61 et loop ((max-va
adf0: 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 l (car inlst))..
ae00: 20 20 20 20 20 28 68 65 64 20 20 20 20 20 28 63 (hed (c
ae10: 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 20 ar inlst))..
ae20: 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 69 (tal (cdr i
ae30: 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 nlst))). (if
ae40: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
ae50: 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 65 )..(loop (max he
ae60: 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 20 d max-val)..
ae70: 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 20 (car tal)..
ae80: 20 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 28 (cdr tal))..(
ae90: 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 max hed max-val)
aea0: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 )))..;; get min
aeb0: 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f or max, use > fo
aec0: 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 r max and < for
aed0: 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 min, this works
aee0: 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 around the limit
aef0: 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 s on apply.;;.(d
af00: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 efine (common:mi
af10: 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 0a n-max comp lst).
af20: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 (if (null? lst
af30: 29 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 62 65 ). #f ;; be
af40: 74 74 65 72 20 74 68 61 6e 20 61 6e 20 65 78 63 tter than an exc
af50: 65 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e 65 eption for my ne
af60: 65 64 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 eds. (fold
af70: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 (lambda (a b)..
af80: 20 20 20 20 20 28 69 66 20 28 63 6f 6d 70 20 61 (if (comp a
af90: 20 62 29 20 61 20 62 29 29 0a 09 20 20 20 20 28 b) a b)).. (
afa0: 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 car lst).. ls
afb0: 74 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e t)))..;; get min
afc0: 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 or max, use > f
afd0: 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 or max and < for
afe0: 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 min, this works
aff0: 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 around the limi
b000: 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 ts on apply.;;.(
b010: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
b020: 75 6d 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e um lst). (if (n
b030: 75 6c 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 ull? lst).
b040: 30 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 0. (fold (l
b050: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 20 ambda (a b)..
b060: 20 20 20 28 2b 20 61 20 62 29 29 0a 09 20 20 20 (+ a b))..
b070: 20 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 (car lst)..
b080: 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 lst)))..;; path
b090: 6c 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 62 list to hash-tab
b0a0: 6c 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 le tree.;; ((a
b0b0: 20 62 20 63 29 28 61 20 62 20 64 29 28 65 20 62 b c)(a b d)(e b
b0c0: 20 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 28 c)) => ((a (b (
b0d0: 64 29 20 28 63 29 29 29 20 28 65 20 28 62 20 28 d) (c))) (e (b (
b0e0: 63 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 c)))).;;.(define
b0f0: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 (common:list->h
b100: 74 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 tree lst). (let
b110: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
b120: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
b130: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
b140: 6c 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 lambda (inlst).
b150: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
b160: 28 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 20 ((ht resh)...
b170: 28 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 29 (hed (car inlst)
b180: 29 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 20 )... (tal (cdr
b190: 69 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 28 inlst))).. (if (
b1a0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
b1b0: 65 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 66 efault ht hed #f
b1c0: 29 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ).. (if (not
b1d0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
b1e0: 20 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 (loop (hash-tab
b1f0: 6c 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a 09 le-ref ht hed)..
b200: 09 20 20 20 20 20 20 20 28 63 61 72 20 74 61 6c . (car tal
b210: 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 20 )... (cdr
b220: 74 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 tal))).. (be
b230: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 73 gin.. (has
b240: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
b250: 68 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 hed (make-hash-t
b260: 61 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 able)).. (
b270: 6c 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c 29 loop ht hed tal)
b280: 29 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 )))). lst).
b290: 20 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 resh))..;; ha
b2a0: 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f sh-table tree to
b2b0: 20 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a html list tree.
b2c0: 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 ;;.;; tipfunc
b2d0: 74 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d 65 takes two parame
b2e0: 74 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 20 ters: y the tip
b2f0: 76 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 74 value and path t
b300: 68 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 20 he path to that
b310: 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 point.;;.(define
b320: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
b330: 68 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 70 html ht path tip
b340: 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 64 func). (let ((d
b350: 61 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 68 atlist .(sort (h
b360: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
b370: 20 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ht).
b380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b390: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
b3a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3c0: 20 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 61 (string< (car a
b3d0: 29 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 20 )(car b)))))).
b3e0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 (if (null? dat
b3f0: 6c 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 66 list). .(tipf
b400: 75 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b 20 unc #f path) ;;
b410: 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 really shouldn't
b420: 20 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 6c get here..(s:ul
b430: 0a 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 .. (map (lambda
b440: 28 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 (x)...(let* ((le
b450: 76 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 29 velname (car x))
b460: 0a 09 09 20 20 20 20 20 20 20 28 79 20 20 20 20 ... (y
b470: 20 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 09 (cdr x))...
b480: 20 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 20 (newpath
b490: 20 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 (append path (
b4a0: 6c 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 list levelname))
b4b0: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 66 )... (leaf
b4c0: 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 (or (not (
b4d0: 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a hash-table? y)).
b4e0: 09 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f .... (null?
b4f0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
b500: 73 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 66 s y)))))... (if
b510: 20 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 73 leaf... (s
b520: 3a 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 6e :li (tipfunc y n
b530: 65 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 ewpath))...
b540: 20 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 (s:li...
b550: 28 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e (list ....leveln
b560: 61 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 ame....(common:h
b570: 74 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 tree->html y new
b580: 70 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 29 path tipfunc))))
b590: 29 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 73 )).. datlis
b5a0: 74 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d t)))))..;; hash-
b5b0: 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 6c table tree to al
b5c0: 69 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 ist tree.;;.(def
b5d0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 ine (common:htre
b5e0: 65 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 28 e->atree ht). (
b5f0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
b600: 09 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 0a . (cons (car x).
b610: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 79 . (let ((y
b620: 20 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 69 (cdr x)))... (i
b630: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 f (hash-table? y
b640: 29 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e )... (common
b650: 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 29 :htree->atree y)
b660: 0a 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 20 ... y)))).
b670: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
b680: 2d 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b ->alist ht)))..;
b690: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
b6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b6d0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e =======.;; M U N
b6e0: 20 47 20 45 20 20 20 44 20 41 20 54 20 41 20 20 G E D A T A
b6f0: 20 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 I N T O N I C
b700: 20 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b E F O R M S.;
b710: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
b720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b750: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 =======..;; Gene
b760: 72 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f rate an index fo
b770: 72 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 r a sparse list
b780: 6f 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b of key values.;;
b790: 20 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 ( (rowname1 c
b7a0: 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f olname1 val1)(ro
b7b0: 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 wname2 colname2
b7c0: 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e val2) ).;;.;; =>
b7d0: 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 .;;.;; ( (row
b7e0: 6e 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 name1 0)(rowname
b7f0: 32 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 2 1)) ;; rown
b800: 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 ames -> num.;;
b810: 20 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 (colname1 0)(
b820: 63 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 colname2 1)) )
b830: 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e ;; colnames -> n
b840: 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e um.;; .;; option
b850: 61 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f al apply proc to
b860: 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 rownum colnum v
b870: 61 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f alue.(define (co
b880: 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 mmon:sparse-list
b890: 2d 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 -generate-index
b8a0: 64 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 data #!key (proc
b8b0: 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c #f)). (if (nul
b8c0: 6c 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 l? data). (
b8d0: 6c 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 list '() '()).
b8e0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
b8f0: 68 65 64 20 28 63 61 72 20 64 61 74 61 29 29 0a hed (car data)).
b900: 09 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 .. (tal (cdr dat
b910: 61 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 a))... (rownames
b920: 20 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d '())... (colnam
b930: 65 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e es '())... (rown
b940: 75 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e um 0)... (coln
b950: 75 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 um 0))..(let*
b960: 28 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 ((rowkey
b970: 20 20 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 (car hed))..
b980: 20 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 (colkey
b990: 20 20 20 20 20 20 20 20 28 63 61 64 72 20 20 68 (cadr h
b9a0: 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 ed)).. (va
b9b0: 6c 75 65 20 20 20 20 20 20 20 20 20 20 20 28 63 lue (c
b9c0: 61 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 addr hed))..
b9d0: 20 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 (existing-row
b9e0: 64 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 dat (assoc rowke
b9f0: 79 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 y rownames))..
ba00: 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 (existing-c
ba10: 6f 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c oldat (assoc col
ba20: 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 key colnames))..
ba30: 20 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 (curr-row
ba40: 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 num (if exis
ba50: 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e ting-rowdat rown
ba60: 75 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 um (+ rownum 1))
ba70: 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d ).. (curr-
ba80: 63 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 colnum (if e
ba90: 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 xisting-coldat c
baa0: 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 olnum (+ colnum
bab0: 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 1))).. (ne
bac0: 77 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 w-rownames (i
bad0: 66 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 f existing-rowda
bae0: 74 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 t rownames (cons
baf0: 20 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 (list rowkey cu
bb00: 72 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 rr-rownum) rowna
bb10: 6d 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 mes))).. (
bb20: 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 new-colnames
bb30: 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c (if existing-col
bb40: 64 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f dat colnames (co
bb50: 6e 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 ns (list colkey
bb60: 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c curr-colnum) col
bb70: 6e 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 names)))).. ;;
bb80: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
bb90: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
bba0: 2d 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 69 -port* "Processi
bbb0: 6e 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 64 ng record: " hed
bbc0: 20 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 28 ).. (if proc (
bbd0: 70 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d proc curr-rownum
bbe0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 curr-colnum row
bbf0: 6b 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 key colkey value
bc00: 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f )).. (if (null?
bc10: 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 tal).. (li
bc20: 73 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 st new-rownames
bc30: 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 new-colnames)..
bc40: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
bc50: 74 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 tal)... (cdr
bc60: 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 tal)... new-r
bc70: 6f 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 ownames... ne
bc80: 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 w-colnames...
bc90: 20 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 (if (> curr-row
bca0: 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 num rownum) curr
bcb0: 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a -rownum rownum).
bcc0: 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 .. (if (> cur
bcd0: 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 r-colnum colnum)
bce0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c curr-colnum col
bcf0: 6e 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 29 num)... )))))
bd00: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
bd10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
bd50: 20 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 Y S T E M S T
bd60: 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U F F.;;=======
bd70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bda0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
bdb0: 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 .;; lazy-safe ge
bdc0: 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e t file mod time.
bdd0: 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 66 on any error (f
bde0: 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 ile not existing
bdf0: 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 0a etc.) return 0.
be00: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
be10: 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 on:lazy-modifica
be20: 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 tion-time fpath)
be30: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
be40: 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a tions. exn.
be50: 20 20 20 20 20 20 30 0a 20 20 20 20 28 66 69 6c 0. (fil
be60: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
be70: 69 6d 65 20 66 70 61 74 68 29 29 29 0a 0a 3b 3b ime fpath)))..;;
be80: 20 66 69 6e 64 20 74 69 6d 65 73 74 61 6d 70 20 find timestamp
be90: 6f 66 20 6e 65 77 65 73 74 20 66 69 6c 65 20 61 of newest file a
bea0: 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 61 ssociated with a
beb0: 20 73 71 6c 69 74 65 20 64 62 20 66 69 6c 65 0a sqlite db file.
bec0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
bed0: 6c 61 7a 79 2d 73 71 6c 69 74 65 2d 64 62 2d 6d lazy-sqlite-db-m
bee0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
bef0: 20 66 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 fpath). (let*
bf00: 28 28 67 6c 6f 62 2d 6c 69 73 74 20 28 68 61 6e ((glob-list (han
bf10: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
bf20: 09 09 65 78 6e 0a 09 09 09 60 28 2c 28 63 6f 6e ..exn....`(,(con
bf30: 63 20 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 c "/no/such/file
bf40: 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 , message: " ((c
bf50: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
bf60: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
bf70: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 'message) exn)))
bf80: 0a 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 28 ... (glob (
bf90: 63 6f 6e 63 20 66 70 61 74 68 20 22 2a 22 29 29 conc fpath "*"))
bfa0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 69 6c )). (fil
bfb0: 65 2d 6c 69 73 74 20 28 69 66 20 28 65 71 3f 20 e-list (if (eq?
bfc0: 30 20 28 6c 65 6e 67 74 68 20 67 6c 6f 62 2d 6c 0 (length glob-l
bfd0: 69 73 74 29 29 0a 09 09 09 27 28 22 2f 6e 6f 2f ist))....'("/no/
bfe0: 73 75 63 68 2f 66 69 6c 65 22 29 0a 09 09 09 67 such/file")....g
bff0: 6c 6f 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 61 lob-list))). (a
c000: 70 70 6c 79 20 6d 61 78 0a 20 20 20 28 6d 61 70 pply max. (map
c010: 0a 20 20 20 20 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 . common:lazy
c020: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
c030: 6d 65 20 0a 20 20 20 20 66 69 6c 65 2d 6c 69 73 me . file-lis
c040: 74 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e t))))..;; return
c050: 20 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 a nice clean pa
c060: 74 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 6f thname made abso
c070: 6c 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 6f lute.(define (co
c080: 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 mmon:nice-path d
c090: 69 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 ir). (let ((mat
c0a0: 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ch (string-match
c0b0: 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c "^(~[^\\/]*)(\\
c0c0: 2f 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a 20 /.*|)$" dir))).
c0d0: 20 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 (if match ;;
c0e0: 75 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 using ~ for home
c0f0: 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d ?..(common:nice-
c100: 70 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d path (conc (comm
c110: 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 on:read-link-f (
c120: 63 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f 22 cadr match)) "/"
c130: 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 (caddr match)))
c140: 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 ..(normalize-pat
c150: 68 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f 6c hname (if (absol
c160: 75 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 ute-pathname? di
c170: 72 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 28 r).....dir.....(
c180: 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 69 conc (current-di
c190: 72 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 72 rectory) "/" dir
c1a0: 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 ))))))..;; make
c1b0: 22 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 69 "nice-path" avai
c1c0: 6c 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 lable in config
c1d0: 66 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 65 files and the re
c1e0: 70 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 2d pl.(define nice-
c1f0: 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 path common:nice
c200: 2d 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 -path)..(define
c210: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e (common:read-lin
c220: 6b 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 6e k-f path). (han
c230: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
c240: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 28 exn. (
c250: 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 begin..(debug:pr
c260: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
c270: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
c280: 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 command \"/bin/r
c290: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 eadlink -f " pat
c2a0: 68 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a h "\" failed.").
c2b0: 09 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 .path) ;; just g
c2c0: 69 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 68 ive up. (with
c2d0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
c2e0: 0a 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 ..(conc "/bin/re
c2f0: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 adlink -f " path
c300: 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ). (lambda
c310: 28 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 ()..(read-line))
c320: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
c330: 74 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 t-cpu-load #!key
c340: 20 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 (remote-host #f
c350: 29 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f )). (car (commo
c360: 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 n:get-cpu-load r
c370: 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b emote-host))).;;
c380: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d (let* ((load-
c390: 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 res (process:cmd
c3a0: 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 -run->list "upti
c3b0: 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 me")).;; . (load
c3c0: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f -rx (regexp "lo
c3d0: 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 ad average:\\s+(
c3e0: 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 \\d+)")).;; . (c
c3f0: 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 pu-load #f)).;;
c400: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
c410: 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 ambda (l).;; ..(
c420: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
c430: 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d ing-search load-
c440: 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 rx l))).;; .. (
c450: 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 if match.;; ..
c460: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 (let ((newva
c470: 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 l (string->numbe
c480: 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 r (cadr match)))
c490: 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 6d ).;; ...(if (num
c4a0: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 ber? newval).;;
c4b0: 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 75 ... (set! cpu
c4c0: 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 29 -load newval))))
c4d0: 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 61 )).;; . (ca
c4e0: 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 r load-res)).;;
c4f0: 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a cpu-load))..
c500: 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 20 ;; get cpu load
c510: 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 by reading from
c520: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 /proc/loadavg, r
c530: 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 eturn all three
c540: 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e values.;;.(defin
c550: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 e (common:get-cp
c560: 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f u-load remote-ho
c570: 73 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 st). (if remote
c580: 2d 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 70 -host. (map
c590: 20 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a 09 (lambda (res)..
c5a0: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
c5b0: 6a 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 20 ject? res) 9e99
c5c0: 72 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 2d res)).. (with-
c5d0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
c5e0: 0a 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 .. (conc "ssh
c5f0: 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 " remote-host "
c600: 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 cat /proc/loada
c610: 76 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 vg").. (lambd
c620: 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 29 a ()(list (read)
c630: 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 29 (read)(read)))))
c640: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 . (with-inp
c650: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 ut-from-file "/p
c660: 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 roc/loadavg" ..(
c670: 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 lambda ()(list (
c680: 72 65 61 64 29 28 72 65 61 64 29 28 72 65 61 64 read)(read)(read
c690: 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6e ))))))..;; get n
c6a0: 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f ormalized cpu lo
c6b0: 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 ad by reading fr
c6c0: 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 om /proc/loadavg
c6d0: 20 61 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 6e and /proc/cpuin
c6e0: 66 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 fo return all th
c6f0: 72 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 74 ree values and t
c700: 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 61 he number of rea
c710: 6c 20 63 70 75 73 20 61 6e 64 20 74 68 65 20 6e l cpus and the n
c720: 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 73 umber of threads
c730: 0a 3b 3b 20 72 65 74 75 72 6e 73 20 61 6c 69 73 .;; returns alis
c740: 74 20 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 t '((adj-cpu-loa
c750: 64 20 2e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d 70 d . normalized-p
c760: 72 6f 63 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 74 roc-load) ... et
c770: 63 2e 0a 3b 3b 20 20 6b 65 79 73 3a 20 61 64 6a c..;; keys: adj
c780: 2d 70 72 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a 2d -proc-load, adj-
c790: 63 6f 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c 6f core-load, 1m-lo
c7a0: 61 64 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 6d ad, 5m-load, 15m
c7b0: 2d 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 -load.;;.(define
c7c0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 (common:get-nor
c7d0: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
c7e0: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 remote-host).
c7f0: 28 6c 65 74 20 28 28 64 61 74 61 20 28 69 66 20 (let ((data (if
c800: 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 remote-host.
c810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
c820: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
c830: 69 70 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 ipe .
c840: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 73 (conc "s
c850: 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 sh " remote-host
c860: 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 " cat /proc/loa
c870: 64 61 76 67 3b 63 61 74 20 2f 70 72 6f 63 2f 63 davg;cat /proc/c
c880: 70 75 69 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 22 puinfo;echo end"
c890: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c8a0: 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 read-lines)
c8b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c8c0: 20 20 20 28 61 70 70 65 6e 64 20 0a 20 20 20 20 (append .
c8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c8e0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
c8f0: 66 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 file "/proc/load
c900: 61 76 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 avg" .
c910: 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 2d read-
c920: 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 20 lines).
c930: 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d (with-
c940: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
c950: 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 0a "/proc/cpuinfo".
c960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c970: 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 read-lines)
c980: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c990: 20 20 20 20 28 6c 69 73 74 20 22 65 6e 64 22 29 (list "end")
c9a0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 6f 61 ))). (loa
c9b0: 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e d-rx (regexp "^
c9c0: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 ([\\d\\.]+)\\s+(
c9d0: 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b [\\d\\.]+)\\s+([
c9e0: 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a 24 \\d\\.]+)\\s+.*$
c9f0: 22 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 6f ")). (pro
ca00: 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e c-rx (regexp "^
ca10: 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c processor\\s+:\\
ca20: 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 s+(\\d+)\\s*$"))
ca30: 0a 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 . (core-r
ca40: 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f 72 x (regexp "^cor
ca50: 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c e id\\s+:\\s+(\\
ca60: 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 d+)\\s*$")).
ca70: 20 20 20 20 28 70 68 79 73 2d 72 78 20 20 28 72 (phys-rx (r
ca80: 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 6c egexp "^physical
ca90: 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 id\\s+:\\s+(\\d
caa0: 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 +)\\s*$")).
cab0: 20 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 (max-num (la
cac0: 6d 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 28 mbda (p n)(max (
cad0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 string->number p
cae0: 29 20 6e 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 ) n)))). ;; (
caf0: 70 72 69 6e 74 20 22 64 61 74 61 3d 22 20 64 61 print "data=" da
cb00: 74 61 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ta). (if (nul
cb10: 6c 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d 65 l? data) ;; some
cb20: 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 thing went wrong
cb30: 0a 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 . #f.
cb40: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
cb50: 68 65 64 20 20 20 20 20 20 28 63 61 72 20 64 61 hed (car da
cb60: 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ta)).
cb70: 20 20 20 20 20 20 20 20 28 74 61 6c 20 20 20 20 (tal
cb80: 20 20 28 63 64 72 20 64 61 74 61 29 29 0a 20 20 (cdr data)).
cb90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cba0: 20 28 6c 6f 61 64 73 20 20 20 20 23 66 29 0a 20 (loads #f).
cbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbc0: 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 20 (proc-num 0)
cbd0: 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e 63 ;; processor inc
cbe0: 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a 20 20 ludes threads.
cbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc00: 20 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 3b (phys-num 0) ;
cc10: 3b 20 70 68 79 73 69 63 61 6c 20 63 68 69 70 20 ; physical chip
cc20: 6f 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a 20 on motherboard.
cc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc40: 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 20 (core-num 0))
cc50: 3b 3b 20 63 6f 72 65 0a 20 20 20 20 20 20 20 20 ;; core.
cc60: 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 20 ;; (print hed
cc70: 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 ", " loads ", "
cc80: 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 proc-num ", " ph
cc90: 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 ys-num ", " core
cca0: 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 20 20 -num).
ccb0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 (if (null? tal)
ccc0: 3b 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 ;; have all our
ccd0: 64 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 data, calculate
cce0: 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 normalized load
ccf0: 61 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 6c and return resul
cd00: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
cd10: 28 6c 65 74 2a 20 28 28 61 63 74 2d 70 72 6f 63 (let* ((act-proc
cd20: 20 28 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 29 29 (+ proc-num 1))
cd30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cd40: 20 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 20 (act-phys
cd50: 28 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a (+ phys-num 1)).
cd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd70: 20 20 20 20 20 28 61 63 74 2d 63 6f 72 65 20 28 (act-core (
cd80: 2b 20 63 6f 72 65 2d 6e 75 6d 20 31 29 29 0a 20 + core-num 1)).
cd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cda0: 20 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f (adj-proc-lo
cdb0: 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 ad (/ (car loads
cdc0: 29 20 61 63 74 2d 70 72 6f 63 29 29 0a 20 20 20 ) act-proc)).
cdd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cde0: 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 (adj-core-load
cdf0: 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 (/ (car loads)
ce00: 61 63 74 2d 63 6f 72 65 29 29 29 0a 20 20 20 20 act-core))).
ce10: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
ce20: 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 end (list (cons
ce30: 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 61 'adj-proc-load a
ce40: 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 20 dj-proc-load).
ce50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce60: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
ce70: 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 s 'adj-core-load
ce80: 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 29 adj-core-load))
ce90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cea0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 (list (
ceb0: 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 63 cons '1m-load (c
cec0: 61 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 ar loads)).
ced0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cee0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 (cons '
cef0: 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c 6f 5m-load (cadr lo
cf00: 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ads)).
cf10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf20: 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d 6c (cons '15m-l
cf30: 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 64 73 oad (caddr loads
cf40: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
cf50: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
cf60: 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 63 t (cons 'proc ac
cf70: 74 2d 70 72 6f 63 29 0a 20 20 20 20 20 20 20 20 t-proc).
cf80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf90: 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6f 72 (cons 'cor
cfa0: 65 20 61 63 74 2d 63 6f 72 65 29 0a 20 20 20 20 e act-core).
cfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfc0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
cfd0: 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 29 29 'phys act-phys))
cfe0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
cff0: 20 28 72 65 67 65 78 2d 63 61 73 65 0a 20 20 20 (regex-case.
d000: 20 20 20 20 20 20 20 20 20 20 20 20 68 65 64 0a hed.
d010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d020: 6c 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 20 load-rx ( x l1
d030: 6c 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 l5 l15 ) (loop (
d040: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
d050: 29 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 )(map string->nu
d060: 6d 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 mber (list l1 l5
d070: 20 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 l15)) proc-num
d080: 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 phys-num core-nu
d090: 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 m)).
d0a0: 20 20 20 28 70 72 6f 63 2d 72 78 20 20 28 20 78 (proc-rx ( x
d0b0: 20 70 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f p ) (lo
d0c0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
d0d0: 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 tal) loads
d0e0: 20 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 70 (max-num p
d0f0: 20 70 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 2d proc-num) phys-
d100: 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 num core-num)).
d110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
d120: 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 20 hys-rx ( x p
d130: 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 ) (loop (c
d140: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
d150: 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 loads
d160: 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d 6e proc-num (max-n
d170: 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 63 um p phys-num) c
d180: 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 ore-num)).
d190: 20 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 (core-r
d1a0: 78 20 20 28 20 78 20 63 20 20 20 20 20 20 20 20 x ( x c
d1b0: 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ) (loop (car ta
d1c0: 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
d1d0: 73 20 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 s proc
d1e0: 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 6d -num phys-num (m
d1f0: 61 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e 75 ax-num c core-nu
d200: 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 m))).
d210: 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 (else .
d220: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
d230: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
d240: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4e ;; (print "N
d250: 4f 20 4d 41 54 43 48 3a 20 22 20 68 65 64 29 0a O MATCH: " hed).
d260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d270: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
d280: 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 )(cdr tal) loads
d290: 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e proc-num phys-n
d2a0: 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 um core-num)))))
d2b0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
d2c0: 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 ommon:unix-ping
d2d0: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 hostname). (let
d2e0: 20 28 28 72 65 73 20 28 73 79 73 74 65 6d 20 28 ((res (system (
d2f0: 63 6f 6e 63 20 22 70 69 6e 67 20 2d 63 20 31 20 conc "ping -c 1
d300: 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 3e 20 2f " hostname " > /
d310: 64 65 76 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 20 dev/null")))).
d320: 20 20 28 65 71 3f 20 72 65 73 20 30 29 29 29 0a (eq? res 0))).
d330: 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 70 75 74 20 .;; ideally put
d340: 61 6c 6c 20 74 68 69 73 20 69 6e 66 6f 20 69 6e all this info in
d350: 74 6f 20 74 68 65 20 64 62 2c 20 6e 6f 20 6e 65 to the db, no ne
d360: 65 64 20 74 6f 20 70 72 65 73 65 72 76 65 20 69 ed to preserve i
d370: 74 20 61 63 72 6f 73 73 20 6d 6f 76 69 6e 67 20 t across moving
d380: 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 72 homehost.;;.;; r
d390: 65 74 75 72 6e 20 6c 69 73 74 20 6f 66 0a 3b 3b eturn list of.;;
d3a0: 20 20 28 20 72 65 61 63 68 61 62 6c 65 3f 20 63 ( reachable? c
d3b0: 70 75 6c 6f 61 64 20 75 70 64 61 74 65 2d 74 69 puload update-ti
d3c0: 6d 65 20 29 0a 28 64 65 66 69 6e 65 20 28 63 6f me ).(define (co
d3d0: 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 6e mmon:get-host-in
d3e0: 66 6f 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 fo hostname). (
d3f0: 6c 65 74 2a 20 28 28 6c 6f 61 64 69 6e 66 6f 20 let* ((loadinfo
d400: 28 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 2d (rmt:get-latest-
d410: 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 host-load hostna
d420: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c me)). (l
d430: 6f 61 64 20 28 63 61 72 20 6c 6f 61 64 69 6e 66 oad (car loadinf
d440: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f o)). (lo
d450: 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 28 ad-sample-time (
d460: 63 64 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 cdr loadinfo)).
d470: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 (load-sa
d480: 6d 70 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 mple-age (- (cur
d490: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 6f rent-seconds) lo
d4a0: 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 29 ad-sample-time))
d4b0: 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 69 . (loadi
d4c0: 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f nfo-timeout-seco
d4d0: 6e 64 73 20 32 30 29 0a 20 20 20 20 20 20 20 20 nds 20).
d4e0: 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 (host-last-upda
d4f0: 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e te-timeout-secon
d500: 64 73 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 ds 10).
d510: 28 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 2d (host-rec (hash-
d520: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
d530: 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 t *host-loads* h
d540: 6f 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 ostname #f)).
d550: 20 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f 6e ). (con
d560: 64 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 2d d. ((< load-
d570: 73 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 69 sample-age loadi
d580: 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f nfo-timeout-seco
d590: 6e 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 nds). (list
d5a0: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t.
d5b0: 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 load-sample-time
d5c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 . loa
d5d0: 64 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 68 d)). ((and h
d5e0: 6f 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 20 ost-rec.
d5f0: 20 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 (< (current-s
d600: 65 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 74 econds) (+ (host
d610: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 -last-update hos
d620: 74 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 74 t-rec) host-last
d630: 2d 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d -update-timeout-
d640: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 seconds))).
d650: 20 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 (list #t.
d660: 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 (host-last
d670: 2d 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 -update host-rec
d680: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 ). (h
d690: 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 ost-last-cpuload
d6a0: 20 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 20 host-rec ))).
d6b0: 20 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 ((common:unix
d6c0: 2d 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a -ping hostname).
d6d0: 20 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 (list #t.
d6e0: 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 (curr
d6f0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 ent-seconds).
d700: 20 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d (alist-
d710: 72 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f ref 'adj-core-lo
d720: 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e ad (common:get-n
d730: 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
d740: 61 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a ad hostname)))).
d750: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
d760: 20 28 6c 69 73 74 20 23 66 20 30 20 2d 31 29 29 (list #f 0 -1))
d770: 29 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 ))). .(define
d780: 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d (common:update-
d790: 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 host-loads-table
d7a0: 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 6c hosts-raw). (l
d7b0: 65 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 6c et* ((hosts (fil
d7c0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
d7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7e0: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
d7f0: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
d800: 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 "^\\S+$") x)).
d810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d820: 20 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 hosts-raw)
d830: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
d840: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 . (lambda (h
d850: 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 ostname).
d860: 28 6c 65 74 2a 20 28 28 72 65 63 20 20 20 20 20 (let* ((rec
d870: 20 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 68 (let ((h (hash
d880: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
d890: 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 lt *host-loads*
d8a0: 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 20 hostname #f))).
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8c0: 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 (if h.
d8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 0a 20 h.
d8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d900: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
d910: 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 t ((h (make-host
d920: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
d930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d940: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
d950: 73 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 set! *host-loads
d960: 2a 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 * hostname h).
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 29 h)
d990: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
d9a0: 20 20 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 20 (host-info
d9b0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
d9c0: 2d 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 6e -host-info hostn
d9d0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ame)).
d9e0: 20 20 20 20 28 69 73 2d 72 65 61 63 68 61 62 6c (is-reachabl
d9f0: 65 20 20 20 20 20 20 28 63 61 72 20 68 6f 73 74 e (car host
da00: 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 -info)).
da10: 20 20 20 20 20 20 28 6c 61 73 74 2d 72 65 61 63 (last-reac
da20: 68 65 64 2d 74 69 6d 65 20 28 63 61 64 72 20 68 hed-time (cadr h
da30: 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 ost-info)).
da40: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 20 (load
da50: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 (cad
da60: 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 0a dr host-info))).
da70: 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 72 (host-r
da80: 65 61 63 68 61 62 6c 65 2d 73 65 74 21 20 20 20 eachable-set!
da90: 20 72 65 63 20 69 73 2d 72 65 61 63 68 61 62 6c rec is-reachabl
daa0: 65 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 e). (hos
dab0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 t-last-update-se
dac0: 74 21 20 20 72 65 63 20 6c 61 73 74 2d 72 65 61 t! rec last-rea
dad0: 63 68 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 20 ched-time).
dae0: 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 (host-last-c
daf0: 70 75 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 20 puload-set! rec
db00: 6c 6f 61 64 29 29 29 0a 20 20 20 20 20 68 6f 73 load))). hos
db10: 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ts)))..(define (
db20: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 common:get-least
db30: 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f 73 -loaded-host hos
db40: 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 ts-raw). (let*
db50: 28 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 ((hosts (filter
db60: 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 (lambda (x).
db70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db80: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 (string-ma
db90: 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c tch (regexp "^\\
dba0: 53 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 S+$") x)).
dbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbc0: 20 20 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 20 hosts-raw)).
dbd0: 20 20 20 20 20 20 20 28 62 65 73 74 2d 68 6f 73 (best-hos
dbe0: 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 t #f). (
dbf0: 62 65 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 29 best-load 99999)
dc00: 0a 20 20 20 20 20 20 20 20 20 28 63 75 72 72 2d . (curr-
dc10: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
dc20: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 63 6f conds))). (co
dc30: 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 mmon:update-host
dc40: 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 -loads-table hos
dc50: 74 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ts). (for-eac
dc60: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
dc70: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 hostname).
dc80: 20 28 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 20 (let* ((rec.
dc90: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
dca0: 20 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c 65 ((h (hash-table
dcb0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f -ref/default *ho
dcc0: 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 st-loads* hostna
dcd0: 6d 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 me #f))).
dce0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a (if h.
dcf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd00: 20 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 20 h.
dd10: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
dd20: 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 ((h (make-host)
dd30: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
dd40: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
dd50: 74 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 74 table-set! *host
dd60: 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 -loads* hostname
dd70: 20 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h).
dd80: 20 20 20 20 20 20 20 20 20 20 20 68 29 29 29 29 h))))
dd90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
dda0: 72 65 61 63 68 61 62 6c 65 20 28 68 6f 73 74 2d reachable (host-
ddb0: 72 65 61 63 68 61 62 6c 65 20 72 65 63 29 29 0a reachable rec)).
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
ddd0: 6f 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d 6c oad (host-l
dde0: 61 73 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 65 ast-cpuload re
ddf0: 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 c))). (c
de00: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 28 ond. ((
de10: 6e 6f 74 20 72 65 61 63 68 61 62 6c 65 29 20 23 not reachable) #
de20: 66 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 3c f). ((<
de30: 20 28 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 6e (+ load (/ (ran
de40: 64 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 dom 250) 1000))
de50: 20 20 20 20 20 20 20 20 3b 3b 20 61 64 64 20 61 ;; add a
de60: 20 72 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 74 random factor t
de70: 6f 20 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 74 o keep from gett
de80: 69 6e 67 20 69 6e 20 61 20 72 75 74 0a 20 20 20 ing in a rut.
de90: 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 62 65 (+ be
dea0: 73 74 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 st-load (/ (rand
deb0: 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 om 250) 1000))
dec0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 ). (se
ded0: 74 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f 61 t! best-load loa
dee0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 d). (s
def0: 65 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 6f et! best-host ho
df00: 73 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 stname))))).
df10: 20 68 6f 73 74 73 29 0a 20 20 20 20 62 65 73 74 hosts). best
df20: 2d 68 6f 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 -host))..(define
df30: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
df40: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
df50: 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 d numcpus waitde
df60: 6c 61 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 lay #!key (count
df70: 20 31 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 1000) (msg #f)(
df80: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 remote-host #f))
df90: 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 . (let* ((loada
dfa0: 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 vg (common:get-c
dfb0: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
dfc0: 6f 73 74 29 29 0a 09 20 28 66 69 72 73 74 20 20 ost)).. (first
dfd0: 20 28 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a (car loadavg)).
dfe0: 09 20 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 . (next (cadr
dff0: 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 loadavg)).. (ad
e000: 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 jload (* maxload
e010: 20 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f numcpus)).. (lo
e020: 61 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e adjmp (- first n
e030: 65 78 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 ext))). (cond
e040: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 . ((and (> f
e050: 69 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 irst adjload)..
e060: 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 (> count 0)).
e070: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
e080: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
e090: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
e0a0: 74 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 ting " waitdelay
e0b0: 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 " seconds due t
e0c0: 6f 20 6c 6f 61 64 20 22 20 66 69 72 73 74 20 22 o load " first "
e0d0: 20 65 78 63 65 65 64 69 6e 67 20 6d 61 78 20 6f exceeding max o
e0e0: 66 20 22 20 61 64 6a 6c 6f 61 64 20 22 20 22 20 f " adjload " "
e0f0: 28 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 (if msg msg ""))
e100: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
e110: 6c 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 leep! waitdelay)
e120: 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 . (common:w
e130: 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 ait-for-cpuload
e140: 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 maxload numcpus
e150: 77 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a waitdelay count:
e160: 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 (- count 1))).
e170: 20 20 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 ((and (> loa
e180: 64 6a 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 djmp numcpus)..
e190: 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 (> count 0)).
e1a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
e1b0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
e1c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
e1d0: 74 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 ting " waitdelay
e1e0: 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 " seconds due t
e1f0: 6f 20 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f o load jump " lo
e200: 61 64 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 adjmp " > numcpu
e210: 73 20 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 s " numcpus (if
e220: 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 msg msg "")).
e230: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
e240: 21 20 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 ! waitdelay).
e250: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d (common:wait-
e260: 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c for-cpuload maxl
e270: 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 oad numcpus wait
e280: 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 delay count: (-
e290: 63 6f 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 count 1))))))..(
e2a0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
e2b0: 61 69 74 2d 66 6f 72 2d 68 6f 6d 65 68 6f 73 74 ait-for-homehost
e2c0: 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6d 73 -load maxload ms
e2d0: 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 68 2d g). (let* ((hh-
e2e0: 64 61 74 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a dat (if (common:
e2f0: 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 20 3b 3b on-homehost?) ;;
e300: 20 69 66 20 77 65 20 61 72 65 20 6f 6e 20 74 68 if we are on th
e310: 65 20 68 6f 6d 65 68 6f 73 74 20 74 68 65 6e 20 e homehost then
e320: 70 61 73 73 20 69 6e 20 23 66 20 73 6f 20 74 68 pass in #f so th
e330: 65 20 63 61 6c 6c 73 20 61 72 65 20 6c 6f 63 61 e calls are loca
e340: 6c 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 l..
e350: 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 #f.
e360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e370: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
e380: 68 6f 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 host))).
e390: 20 28 68 68 20 20 20 20 20 28 69 66 20 68 68 2d (hh (if hh-
e3a0: 64 61 74 20 28 63 61 72 20 68 68 2d 64 61 74 29 dat (car hh-dat)
e3b0: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 #f)). (
e3c0: 6e 75 6d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a numcpus (common:
e3d0: 67 65 74 2d 6e 75 6d 2d 63 70 75 73 20 68 68 29 get-num-cpus hh)
e3e0: 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 )). (common:w
e3f0: 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a ait-for-normaliz
e400: 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 ed-load maxload
e410: 6d 73 67 3a 20 6d 73 67 20 72 65 6d 6f 74 65 2d msg: msg remote-
e420: 68 6f 73 74 3a 20 68 68 29 29 29 0a 0a 28 64 65 host: hh)))..(de
e430: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
e440: 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 -num-cpus remote
e450: 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 -host). (let ((
e460: 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 0a proc (lambda ().
e470: 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 ..(let loop ((nu
e480: 6d 63 70 75 20 30 29 0a 09 09 09 20 20 20 28 69 mcpu 0).... (i
e490: 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 nl (read-line
e4a0: 29 29 29 0a 09 09 20 20 28 69 66 20 28 65 6f 66 )))... (if (eof
e4b0: 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 -object? inl)...
e4c0: 20 20 20 20 20 20 6e 75 6d 63 70 75 0a 09 09 20 numcpu...
e4d0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 (loop (if (
e4e0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 string-match "^p
e4f0: 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 rocessor\\s+:\\s
e500: 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 +\\d+$" inl)....
e510: 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 .(+ numcpu 1)...
e520: 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 20 20 20 ..numcpu)....
e530: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 (read-line)))))
e540: 29 29 0a 20 20 20 20 28 69 66 20 72 65 6d 6f 74 )). (if remot
e550: 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 2d 69 6e e-host..(with-in
e560: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 put-from-pipe ..
e570: 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 72 65 (conc "ssh " re
e580: 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 74 20 mote-host " cat
e590: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 29 0a /proc/cpuinfo").
e5a0: 09 20 70 72 6f 63 29 0a 09 28 77 69 74 68 2d 69 . proc)..(with-i
e5b0: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 nput-from-file "
e5c0: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 20 70 /proc/cpuinfo" p
e5d0: 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 61 69 74 roc))))..;; wait
e5e0: 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 for normalized
e5f0: 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 cpu load to drop
e600: 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b below maxload.;
e610: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
e620: 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 n:wait-for-norma
e630: 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f lized-load maxlo
e640: 61 64 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 ad #!key (msg #f
e650: 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 )(remote-host #f
e660: 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d )). (let ((num-
e670: 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 cpus (common:get
e680: 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 -num-cpus remote
e690: 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 63 6f -host))). (co
e6a0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
e6b0: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
e6c0: 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a 20 6d m-cpus 15 msg: m
e6d0: 73 67 20 72 65 6d 6f 74 65 2d 68 6f 73 74 3a 20 sg remote-host:
e6e0: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 0a remote-host)))..
e6f0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 6e 61 (define (get-una
e700: 6d 65 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 me . params). (
e710: 6c 65 74 2a 20 28 28 75 6e 61 6d 65 2d 72 65 73 let* ((uname-res
e720: 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 (process:cmd-ru
e730: 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 n->list (conc "u
e740: 6e 61 6d 65 20 22 20 28 69 66 20 28 6e 75 6c 6c name " (if (null
e750: 3f 20 70 61 72 61 6d 73 29 20 22 2d 61 22 20 28 ? params) "-a" (
e760: 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 29 0a car params))))).
e770: 09 20 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 20 . (uname #f)).
e780: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 61 (if (null? (ca
e790: 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 22 r uname-res)).."
e7a0: 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 20 unknown"..(caar
e7b0: 75 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a 0a 3b uname-res))))..;
e7c0: 3b 20 66 6f 72 20 72 65 61 73 6f 6e 73 20 49 20 ; for reasons I
e7d0: 64 6f 6e 27 74 20 75 6e 64 65 72 73 74 61 6e 64 don't understand
e7e0: 20 6d 75 6c 74 69 70 6c 65 20 63 61 6c 6c 73 20 multiple calls
e7f0: 74 6f 20 72 65 61 6c 2d 70 61 74 68 20 69 6e 20 to real-path in
e800: 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 73 parallel threads
e810: 0a 3b 3b 20 6d 75 73 74 20 62 65 20 70 72 6f 74 .;; must be prot
e820: 65 63 74 65 64 20 62 79 20 6d 75 74 65 78 65 73 ected by mutexes
e830: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
e840: 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 68 20 69 6e mon:real-path in
e850: 70 61 74 68 29 0a 20 20 3b 3b 20 28 70 72 6f 63 path). ;; (proc
e860: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 68 ess:cmd-run-with
e870: 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 22 72 -stderr->list "r
e880: 65 61 64 6c 69 6e 6b 22 20 22 2d 66 22 20 69 6e eadlink" "-f" in
e890: 70 61 74 68 29 29 20 3b 3b 20 63 6d 64 20 2e 20 path)) ;; cmd .
e8a0: 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 6c 65 params). ;; (le
e8b0: 74 2d 76 61 6c 75 65 73 20 0a 20 20 3b 3b 20 20 t-values . ;;
e8c0: 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 20 (((inp oup pid)
e8d0: 28 70 72 6f 63 65 73 73 20 22 72 65 61 64 6c 69 (process "readli
e8e0: 6e 6b 22 20 28 6c 69 73 74 20 22 2d 66 22 20 69 nk" (list "-f" i
e8f0: 6e 70 61 74 68 29 29 29 29 0a 20 20 3b 3b 20 20 npath)))). ;;
e900: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
e910: 2d 70 6f 72 74 20 69 6e 70 0a 20 20 3b 3b 20 20 -port inp. ;;
e920: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e (let loop ((in
e930: 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 20 l (read-line)).
e940: 20 3b 3b 20 20 20 20 20 20 20 09 28 72 65 73 20 ;; .(res
e950: 23 66 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 #f)). ;; (
e960: 70 72 69 6e 74 20 22 69 6e 6c 3d 22 20 69 6e 6c print "inl=" inl
e970: 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 69 66 20 ). ;; (if
e980: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c (eof-object? inl
e990: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ). ;;
e9a0: 28 62 65 67 69 6e 0a 20 20 3b 3b 20 20 20 20 20 (begin. ;;
e9b0: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e (close-in
e9c0: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 put-port inp).
e9d0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ;; (c
e9e0: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
e9f0: 20 6f 75 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 oup). ;;
ea00: 20 20 20 20 20 20 3b 3b 20 28 70 72 6f 63 65 73 ;; (proces
ea10: 73 2d 77 61 69 74 20 70 69 64 29 0a 20 20 3b 3b s-wait pid). ;;
ea20: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 29 res)
ea30: 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 . ;; (
ea40: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
ea50: 20 69 6e 6c 29 29 29 29 29 29 0a 20 20 28 77 69 inl)))))). (wi
ea60: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
ea70: 70 65 20 28 63 6f 6e 63 20 22 72 65 61 64 6c 69 pe (conc "readli
ea80: 6e 6b 20 2d 66 20 22 20 69 6e 70 61 74 68 29 20 nk -f " inpath)
ea90: 72 65 61 64 2d 6c 69 6e 65 29 29 0a 0a 3b 3b 3d read-line))..;;=
eaa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ead0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eae0: 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 20 53 20 4b =====.;; D I S K
eaf0: 20 20 20 53 20 50 20 41 20 43 20 45 20 0a 3b 3b S P A C E .;;
eb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb40: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
eb50: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b (common:get-disk
eb60: 2d 73 70 61 63 65 2d 75 73 65 64 20 66 70 61 74 -space-used fpat
eb70: 68 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 h). (with-input
eb80: 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 -from-pipe (conc
eb90: 20 22 2f 75 73 72 2f 62 69 6e 2f 64 75 20 2d 73 "/usr/bin/du -s
eba0: 20 22 20 66 70 61 74 68 29 20 72 65 61 64 29 29 " fpath) read))
ebb0: 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 61 74 68 20 ..;; given path
ebc0: 67 65 74 20 66 72 65 65 20 73 70 61 63 65 2c 20 get free space,
ebd0: 61 6c 6c 6f 77 73 20 6f 76 65 72 72 69 64 65 20 allows override
ebe0: 69 6e 20 5b 73 65 74 75 70 5d 0a 3b 3b 20 77 69 in [setup].;; wi
ebf0: 74 68 20 66 72 65 65 2d 73 70 61 63 65 2d 73 63 th free-space-sc
ec00: 72 69 70 74 20 2f 70 61 74 68 2f 74 6f 2f 73 6f ript /path/to/so
ec10: 6d 65 2f 73 63 72 69 70 74 2e 73 68 0a 3b 3b 0a me/script.sh.;;.
ec20: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 66 20 (define (get-df
ec30: 70 61 74 68 29 0a 20 20 28 69 66 20 28 63 6f 6e path). (if (con
ec40: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
ec50: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
ec60: 22 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 69 "free-space-scri
ec70: 70 74 22 29 0a 20 20 20 20 20 20 28 77 69 74 68 pt"). (with
ec80: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
ec90: 20 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 . (conc (
eca0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
ecb0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
ecc0: 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d 73 p" "free-space-s
ecd0: 63 72 69 70 74 22 29 20 22 20 22 20 70 61 74 68 cript") " " path
ece0: 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda
ecf0: 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 73 ().. (let ((res
ed00: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 (read-line)))..
ed10: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (if (string?
ed20: 72 65 73 29 0a 09 20 20 20 20 20 20 20 28 73 74 res).. (st
ed30: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 ring->number res
ed40: 29 29 29 29 29 0a 20 20 20 20 20 20 28 67 65 74 ))))). (get
ed50: 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 29 29 -unix-df path)))
ed60: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 ..(define (get-u
ed70: 6e 69 78 2d 64 66 20 70 61 74 68 29 0a 20 20 28 nix-df path). (
ed80: 6c 65 74 2a 20 28 28 64 66 2d 72 65 73 75 6c 74 let* ((df-result
ed90: 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 s (process:cmd-r
eda0: 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 un->list (conc "
edb0: 64 66 20 22 20 70 61 74 68 29 29 29 0a 09 20 28 df " path))).. (
edc0: 73 70 61 63 65 2d 72 78 20 20 20 28 72 65 67 65 space-rx (rege
edd0: 78 70 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 2b xp "([0-9]+)\\s+
ede0: 28 5b 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 28 ([0-9]+)%")).. (
edf0: 66 72 65 65 73 70 63 20 20 20 20 23 66 29 29 0a freespc #f)).
ee00: 20 20 20 20 3b 3b 20 28 77 72 69 74 65 20 64 66 ;; (write df
ee10: 2d 72 65 73 75 6c 74 73 29 0a 20 20 20 20 28 66 -results). (f
ee20: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
ee30: 28 6c 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 (l)...(let ((mat
ee40: 63 68 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 ch (string-searc
ee50: 68 20 73 70 61 63 65 2d 72 78 20 6c 29 29 29 0a h space-rx l))).
ee60: 09 09 20 20 28 69 66 20 6d 61 74 63 68 20 0a 09 .. (if match ..
ee70: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 . (let ((ne
ee80: 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 wval (string->nu
ee90: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
eea0: 29 29 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d ))))....(if (num
eeb0: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 ber? newval)....
eec0: 20 20 20 20 28 73 65 74 21 20 66 72 65 65 73 70 (set! freesp
eed0: 63 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 09 c newval))))))..
eee0: 20 20 20 20 20 20 28 63 61 72 20 64 66 2d 72 65 (car df-re
eef0: 73 75 6c 74 73 29 29 0a 20 20 20 20 66 72 65 65 sults)). free
ef00: 73 70 63 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 spc))..(define (
ef10: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 common:check-spa
ef20: 63 65 2d 69 6e 2d 64 69 72 20 64 69 72 70 61 74 ce-in-dir dirpat
ef30: 68 20 72 65 71 75 69 72 65 64 29 0a 20 20 28 6c h required). (l
ef40: 65 74 2a 20 28 28 64 62 73 70 61 63 65 20 20 28 et* ((dbspace (
ef50: 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 if (directory? d
ef60: 69 72 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 irpath)...
ef70: 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 (get-df dirpath
ef80: 29 0a 09 09 20 20 20 20 20 20 20 30 29 29 29 0a )... 0))).
ef90: 20 20 20 20 28 6c 69 73 74 20 28 3e 20 64 62 73 (list (> dbs
efa0: 70 61 63 65 20 72 65 71 75 69 72 65 64 29 0a 09 pace required)..
efb0: 20 20 64 62 73 70 61 63 65 0a 09 20 20 72 65 71 dbspace.. req
efc0: 75 69 72 65 64 0a 09 20 20 64 69 72 70 61 74 68 uired.. dirpath
efd0: 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 73 70 )))..;; check sp
efe0: 61 63 65 20 69 6e 20 64 62 64 69 72 20 61 6e 64 ace in dbdir and
eff0: 20 69 6e 20 6d 65 67 61 74 65 73 74 20 64 69 72 in megatest dir
f000: 0a 3b 3b 20 72 65 74 75 72 6e 73 3a 20 6f 6b 2f .;; returns: ok/
f010: 6e 6f 74 20 64 62 73 70 61 63 65 20 72 65 71 75 not dbspace requ
f020: 69 72 65 64 2d 73 70 61 63 65 0a 3b 3b 0a 28 64 ired-space.;;.(d
f030: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 efine (common:ch
f040: 65 63 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 eck-db-dir-space
f050: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 71 75 ). (let* ((requ
f060: 69 72 65 64 20 28 73 74 72 69 6e 67 2d 3e 6e 75 ired (string->nu
f070: 6d 62 65 72 20 0a 09 09 20 20 20 20 28 6f 72 20 mber ... (or
f080: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
f090: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
f0a0: 75 70 22 20 22 64 62 64 69 72 2d 73 70 61 63 65 up" "dbdir-space
f0b0: 2d 72 65 71 75 69 72 65 64 22 29 0a 09 09 09 22 -required")...."
f0c0: 31 30 30 30 30 30 22 29 29 29 0a 09 20 28 64 62 100000"))).. (db
f0d0: 64 69 72 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 dir (common:g
f0e0: 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 et-db-tmp-area))
f0f0: 20 3b 3b 20 28 64 62 3a 67 65 74 2d 64 62 64 69 ;; (db:get-dbdi
f100: 72 29 29 0a 09 20 28 74 64 62 73 70 61 63 65 20 r)).. (tdbspace
f110: 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 (common:check-sp
f120: 61 63 65 2d 69 6e 2d 64 69 72 20 64 62 64 69 72 ace-in-dir dbdir
f130: 20 72 65 71 75 69 72 65 64 29 29 0a 09 20 28 6d required)).. (m
f140: 64 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a dbspace (common:
f150: 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 check-space-in-d
f160: 69 72 20 2a 74 6f 70 70 61 74 68 2a 20 72 65 71 ir *toppath* req
f170: 75 69 72 65 64 29 29 29 0a 20 20 20 20 28 73 6f uired))). (so
f180: 72 74 20 28 6c 69 73 74 20 74 64 62 73 70 61 63 rt (list tdbspac
f190: 65 20 6d 64 62 73 70 61 63 65 29 20 28 6c 61 6d e mdbspace) (lam
f1a0: 62 64 61 20 28 61 20 62 29 0a 09 09 09 09 20 20 bda (a b).....
f1b0: 20 20 20 28 3c 20 28 63 61 64 72 20 61 29 28 63 (< (cadr a)(c
f1c0: 61 64 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 adr b)))))).
f1d0: 0a 3b 3b 20 63 68 65 63 6b 20 61 76 61 69 6c 61 .;; check availa
f1e0: 62 6c 65 20 73 70 61 63 65 20 69 6e 20 64 62 64 ble space in dbd
f1f0: 69 72 2c 20 65 78 69 74 20 69 66 20 69 6e 73 75 ir, exit if insu
f200: 66 66 69 63 69 65 6e 74 0a 3b 3b 0a 28 64 65 66 fficient.;;.(def
f210: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 ine (common:chec
f220: 6b 2d 64 62 2d 64 69 72 2d 61 6e 64 2d 65 78 69 k-db-dir-and-exi
f230: 74 2d 69 66 2d 69 6e 73 75 66 66 69 63 69 65 6e t-if-insufficien
f240: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 61 t). (let* ((spa
f250: 63 65 64 61 74 20 28 63 61 72 20 28 63 6f 6d 6d cedat (car (comm
f260: 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d on:check-db-dir-
f270: 73 70 61 63 65 29 29 29 20 3b 3b 20 6c 6f 6f 6b space))) ;; look
f280: 20 6f 6e 6c 79 20 61 74 20 77 6f 72 73 74 20 66 only at worst f
f290: 6f 72 20 6e 6f 77 0a 09 20 28 69 73 2d 6f 6b 20 or now.. (is-ok
f2a0: 20 20 20 28 63 61 72 20 73 70 61 63 65 64 61 74 (car spacedat
f2b0: 29 29 0a 09 20 28 64 62 73 70 61 63 65 20 20 28 )).. (dbspace (
f2c0: 63 61 64 72 20 73 70 61 63 65 64 61 74 29 29 0a cadr spacedat)).
f2d0: 09 20 28 72 65 71 75 69 72 65 64 20 28 63 61 64 . (required (cad
f2e0: 64 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 dr spacedat))..
f2f0: 28 64 62 64 69 72 20 20 20 20 28 63 61 64 64 64 (dbdir (caddd
f300: 72 20 73 70 61 63 65 64 61 74 29 29 29 0a 20 20 r spacedat))).
f310: 20 20 28 69 66 20 28 6e 6f 74 20 69 73 2d 6f 6b (if (not is-ok
f320: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
f330: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
f340: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
f350: 6f 72 74 2a 20 22 49 6e 73 75 66 66 69 63 69 65 ort* "Insufficie
f360: 6e 74 20 73 70 61 63 65 20 69 6e 20 22 20 64 62 nt space in " db
f370: 64 69 72 20 22 2c 20 72 65 71 75 69 72 65 20 22 dir ", require "
f380: 20 72 65 71 75 69 72 65 64 20 22 2c 20 68 61 76 required ", hav
f390: 65 20 22 20 64 62 73 70 61 63 65 20 20 22 2c 20 e " dbspace ",
f3a0: 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 exiting now.")..
f3b0: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 20 (exit 1))))).
f3c0: 20 0a 3b 3b 20 70 61 74 68 73 20 69 73 20 6c 69 .;; paths is li
f3d0: 73 74 20 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 st of lists ((na
f3e0: 6d 65 20 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b me path) ... ).;
f3f0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
f400: 6e 3a 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d n:get-disk-with-
f410: 6d 6f 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 most-free-space
f420: 64 69 73 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 disks minsize).
f430: 20 28 6c 65 74 20 28 28 62 65 73 74 20 20 20 20 (let ((best
f440: 20 23 66 29 0a 09 28 62 65 73 74 73 69 7a 65 20 #f)..(bestsize
f450: 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 0)). (for-eac
f460: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
f470: 28 64 69 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 (disk-num).
f480: 20 20 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 (let* ((dirpat
f490: 68 20 20 20 20 28 63 61 64 72 20 28 61 73 73 6f h (cadr (asso
f4a0: 63 20 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 c disk-num disks
f4b0: 29 29 29 0a 09 20 20 20 20 20 20 28 66 72 65 65 ))).. (free
f4c0: 73 70 63 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 spc (cond....
f4d0: 20 20 20 28 28 6e 6f 74 20 28 64 69 72 65 63 74 ((not (direct
f4e0: 6f 72 79 3f 20 64 69 72 70 61 74 68 29 29 0a 09 ory? dirpath))..
f4f0: 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
f500: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
f510: 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 t 300 "disks not
f520: 20 61 20 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 a dir " disk-nu
f530: 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 m).....(debug:pr
f540: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
f550: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
f560: 47 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e G: disk " disk-n
f570: 75 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 um " at path \""
f580: 20 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 dirpath "\" is
f590: 6e 6f 74 20 61 20 64 69 72 65 63 74 6f 72 79 20 not a directory
f5a0: 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 - ignoring it.")
f5b0: 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 ).... -1)....
f5c0: 20 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 ((not (file-w
f5d0: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 69 72 rite-access? dir
f5e0: 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 path)).... (i
f5f0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
f600: 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 ise-print 300 "d
f610: 69 73 6b 73 20 6e 6f 74 20 77 72 69 74 65 61 62 isks not writeab
f620: 6c 65 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 le " disk-num)..
f630: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
f640: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
f650: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 ort* "WARNING: d
f660: 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 isk " disk-num "
f670: 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 at path \"" dir
f680: 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 path "\" is not
f690: 77 72 69 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f writeable - igno
f6a0: 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 ring it."))....
f6b0: 20 20 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e -1).... ((n
f6c0: 6f 74 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d ot (eq? (string-
f6d0: 72 65 66 20 64 69 72 70 61 74 68 20 30 29 20 23 ref dirpath 0) #
f6e0: 5c 2f 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 \/)).... (if
f6f0: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
f700: 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 e-print 300 "dis
f710: 6b 73 20 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 ks not a proper
f720: 70 61 74 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 path " disk-num)
f730: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
f740: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
f750: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
f760: 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d disk " disk-num
f770: 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 " at path \"" d
f780: 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f irpath "\" is no
f790: 74 20 61 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 t a fully qualif
f7a0: 69 65 64 20 70 61 74 68 20 2d 20 69 67 6e 6f 72 ied path - ignor
f7b0: 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 ing it."))....
f7c0: 20 20 2d 31 29 0a 09 09 09 20 20 20 28 65 6c 73 -1).... (els
f7d0: 65 0a 09 09 09 20 20 20 20 28 67 65 74 2d 64 66 e.... (get-df
f7e0: 20 64 69 72 70 61 74 68 29 29 29 29 29 0a 09 20 dirpath)))))..
f7f0: 28 69 66 20 28 3e 20 66 72 65 65 73 70 63 20 62 (if (> freespc b
f800: 65 73 74 73 69 7a 65 29 0a 09 20 20 20 20 20 28 estsize).. (
f810: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 73 begin.. (s
f820: 65 74 21 20 62 65 73 74 20 20 20 20 20 28 63 6f et! best (co
f830: 6e 73 20 64 69 73 6b 2d 6e 75 6d 20 64 69 72 70 ns disk-num dirp
f840: 61 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 73 ath)).. (s
f850: 65 74 21 20 62 65 73 74 73 69 7a 65 20 66 72 65 et! bestsize fre
f860: 65 73 70 63 29 29 29 29 29 0a 20 20 20 20 20 28 espc))))). (
f870: 6d 61 70 20 63 61 72 20 64 69 73 6b 73 29 29 0a map car disks)).
f880: 20 20 20 20 28 69 66 20 28 61 6e 64 20 62 65 73 (if (and bes
f890: 74 20 28 3e 20 62 65 73 74 73 69 7a 65 20 6d 69 t (> bestsize mi
f8a0: 6e 73 69 7a 65 29 29 0a 09 62 65 73 74 0a 09 23 nsize))..best..#
f8b0: 66 29 29 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 f))) ;; #f means
f8c0: 20 6e 6f 20 64 69 73 6b 20 63 61 6e 64 69 64 61 no disk candida
f8d0: 74 65 20 66 6f 75 6e 64 0a 0a 3b 3b 3d 3d 3d 3d te found..;;====
f8e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f8f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f920: 3d 3d 0a 3b 3b 20 45 20 4e 20 56 20 49 20 52 20 ==.;; E N V I R
f930: 4f 20 4e 20 4d 20 45 20 4e 20 54 20 20 20 56 20 O N M E N T V
f940: 41 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d A R S.;;========
f950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 28 ==============.(
f990: 64 65 66 69 6e 65 20 28 62 62 2d 63 68 65 63 6b define (bb-check
f9a0: 2d 70 61 74 68 20 23 21 6b 65 79 20 28 6d 73 67 -path #!key (msg
f9b0: 20 22 63 68 65 63 6b 2d 70 61 74 68 3a 20 22 29 "check-path: ")
f9c0: 29 0a 20 20 28 6c 65 74 20 28 28 70 61 74 68 20 ). (let ((path
f9d0: 28 6f 72 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (or (get-environ
f9e0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 ment-variable "P
f9f0: 41 54 48 22 29 20 22 6e 6f 6e 65 22 29 29 29 0a ATH") "none"))).
fa00: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
fa10: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
fa20: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 6f 6e 63 -log-port* (conc
fa30: 20 6d 73 67 22 20 3a 20 24 50 41 54 48 3d 22 70 msg" : $PATH="p
fa40: 61 74 68 29 29 0a 20 20 20 20 28 69 66 20 28 73 ath)). (if (s
fa50: 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 2e 2a tring-match "^.*
fa60: 2f 69 73 6f 65 6e 76 2d 63 6f 72 65 2f 2e 2a 22 /isoenv-core/.*"
fa70: 20 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 28 path). (
fa80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
fa90: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
faa0: 2d 70 6f 72 74 2a 20 28 63 6f 6e 63 20 6d 73 67 -port* (conc msg
fab0: 22 20 3a 20 21 21 49 53 4f 45 4e 56 20 50 52 45 " : !!ISOENV PRE
fac0: 53 45 4e 54 21 21 22 29 29 20 3b 3b 20 72 65 6d SENT!!")) ;; rem
fad0: 6f 76 65 20 66 6f 72 20 70 72 6f 64 0a 20 20 20 ove for prod.
fae0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
faf0: 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c t-info 1 *defaul
fb00: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 6f 6e t-log-port* (con
fb10: 63 20 6d 73 67 22 20 3a 20 2a 2a 6e 6f 20 69 73 c msg" : **no is
fb20: 6f 65 6e 76 20 70 72 65 73 65 6e 74 2a 2a 22 29 oenv present**")
fb30: 29 29 29 29 0a 0a 09 20 20 20 20 20 20 0a 28 64 ))))... .(d
fb40: 65 66 69 6e 65 20 28 73 61 76 65 2d 65 6e 76 69 efine (save-envi
fb50: 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 ronment-as-files
fb60: 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 69 67 fname #!key (ig
fb70: 6e 6f 72 65 76 61 72 73 20 28 6c 69 73 74 20 22 norevars (list "
fb80: 55 53 45 52 22 20 22 48 4f 4d 45 22 20 22 44 49 USER" "HOME" "DI
fb90: 53 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 SPLAY" "LS_COLOR
fba0: 53 22 20 22 58 4b 45 59 53 59 4d 44 42 22 20 22 S" "XKEYSYMDB" "
fbb0: 45 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 4c 41 EDITOR" "MAKEFLA
fbc0: 47 53 22 20 22 4d 41 4b 45 46 22 20 22 4d 41 4b GS" "MAKEF" "MAK
fbd0: 45 4f 56 45 52 52 49 44 45 53 22 29 29 29 0a 20 EOVERRIDES"))).
fbe0: 20 3b 3b 28 62 62 2d 63 68 65 63 6b 2d 70 61 74 ;;(bb-check-pat
fbf0: 68 20 6d 73 67 3a 20 22 73 61 76 65 2d 65 6e 76 h msg: "save-env
fc00: 69 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 ironment-as-file
fc10: 73 20 65 6e 74 72 79 22 29 0a 20 20 28 6c 65 74 s entry"). (let
fc20: 20 28 28 65 6e 76 76 61 72 73 20 28 67 65 74 2d ((envvars (get-
fc30: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
fc40: 61 62 6c 65 73 29 29 0a 20 20 20 20 20 20 20 20 ables)).
fc50: 28 77 68 69 74 65 73 70 20 28 72 65 67 65 78 70 (whitesp (regexp
fc60: 20 22 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c 5c "[^a-zA-Z0-9_\\
fc70: 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 29 29 0a 09 28 -:,.\\/%$]"))..(
fc80: 6d 75 6e 67 65 76 61 6c 20 28 6c 61 6d 62 64 61 mungeval (lambda
fc90: 20 28 76 61 6c 29 0a 09 09 20 20 20 20 28 63 6f (val)... (co
fca0: 6e 64 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 nd... ((eq?
fcb0: 76 61 6c 20 23 74 29 20 22 22 29 20 3b 3b 20 63 val #t) "") ;; c
fcc0: 6f 6e 76 65 72 74 20 23 74 20 74 6f 20 65 6d 70 onvert #t to emp
fcd0: 74 79 20 73 74 72 69 6e 67 0a 09 09 20 20 20 20 ty string...
fce0: 20 28 28 65 71 3f 20 76 61 6c 20 23 66 29 20 23 ((eq? val #f) #
fcf0: 66 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 66 f) ;; convert #f
fd00: 20 74 6f 20 69 74 73 65 6c 66 20 28 73 74 69 6c to itself (stil
fd10: 6c 20 74 68 69 6e 6b 69 6e 67 20 61 62 6f 75 74 l thinking about
fd20: 20 74 68 69 73 20 6f 6e 65 0a 09 09 20 20 20 20 this one...
fd30: 20 28 65 6c 73 65 20 76 61 6c 29 29 29 29 29 0a (else val))))).
fd40: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
fd50: 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 -to-file (conc f
fd60: 6e 61 6d 65 20 22 2e 63 73 68 22 29 0a 20 20 20 name ".csh").
fd70: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 (lambda ().
fd80: 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 (for-ea
fd90: 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 ch (lambda (keyv
fda0: 61 6c 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 al)... (let
fdb0: 2a 20 28 28 6b 65 79 20 20 20 28 63 61 72 20 6b * ((key (car k
fdc0: 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 eyval))....
fdd0: 28 76 61 6c 20 20 20 28 63 64 72 20 6b 65 79 76 (val (cdr keyv
fde0: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 al)).... (de
fdf0: 6c 69 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d lim (if (string-
fe00: 73 65 61 72 63 68 20 77 68 69 74 65 73 70 20 76 search whitesp v
fe10: 61 6c 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 al) ......"\""..
fe20: 09 09 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 ...."")))....(pr
fe30: 69 6e 74 20 28 69 66 20 28 6f 72 20 28 6d 65 6d int (if (or (mem
fe40: 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 ber key ignoreva
fe50: 72 73 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 rs)..... (
fe60: 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 string-search wh
fe70: 69 74 65 73 70 20 6b 65 79 29 29 0a 09 09 09 09 itesp key)).....
fe80: 20 20 20 22 23 20 73 65 74 65 6e 76 20 22 0a 09 "# setenv "..
fe90: 09 09 09 20 20 20 22 73 65 74 65 6e 76 20 22 29 ... "setenv ")
fea0: 0a 09 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 .... key "
feb0: 20 22 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 " delim (mungev
fec0: 61 6c 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 al val) delim)))
fed0: 0a 09 09 20 20 20 20 65 6e 76 76 61 72 73 29 29 ... envvars))
fee0: 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 ). (with-out
fef0: 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e put-to-file (con
ff00: 63 20 66 6e 61 6d 65 20 22 2e 73 68 22 29 0a 20 c fname ".sh").
ff10: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
ff20: 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d . (for-
ff30: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
ff40: 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 28 6c yval)... (l
ff50: 65 74 2a 20 28 28 6b 65 79 20 28 63 61 72 20 6b et* ((key (car k
ff60: 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 eyval))....
ff70: 28 76 61 6c 20 28 63 64 72 20 6b 65 79 76 61 6c (val (cdr keyval
ff80: 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 6c 69 )).... (deli
ff90: 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 m (if (string-se
ffa0: 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 6c arch whitesp val
ffb0: 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 09 ) ......"\""....
ffc0: 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 69 6e .."")))....(prin
ffd0: 74 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 t (if (or (membe
ffe0: 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 r key ignorevars
fff0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 73 74 )..... (st
10000 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 ring-search whit
10010 65 73 70 20 6b 65 79 29 0a 09 09 09 09 20 20 20 esp key).....
10020 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 61 72 (string-sear
10030 63 68 20 22 3a 22 20 6b 65 79 29 29 20 3b 3b 20 ch ":" key)) ;;
10040 69 6e 74 65 72 6e 61 6c 20 6f 6e 6c 79 20 76 61 internal only va
10050 6c 75 65 73 20 74 6f 20 62 65 20 73 6b 69 70 70 lues to be skipp
10060 65 64 2e 0a 09 09 09 09 20 20 20 22 23 20 65 78 ed...... "# ex
10070 70 6f 72 74 20 22 0a 09 09 09 09 20 20 20 22 65 port "..... "e
10080 78 70 6f 72 74 20 22 29 0a 09 09 09 20 20 20 20 xport ")....
10090 20 20 20 6b 65 79 20 22 3d 22 20 64 65 6c 69 6d key "=" delim
100a0 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 (mungeval val)
100b0 64 65 6c 69 6d 29 29 29 0a 20 20 20 20 20 20 20 delim))).
100c0 20 20 20 20 20 20 20 20 20 20 20 20 20 65 6e 76 env
100d0 76 61 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 vars)))))..;; se
100e0 74 20 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 t some env vars
100f0 66 72 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 from an alist, r
10100 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 eturn an alist w
10110 69 74 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c ith original val
10120 75 65 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 ues.;; (("VAR" "
10130 76 61 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 value") ...).(de
10140 66 69 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 fine (alist->env
10150 2d 76 61 72 73 20 6c 73 74 29 0a 20 20 28 69 66 -vars lst). (if
10160 20 28 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 (list? lst).
10170 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 (let ((res '(
10180 29 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 )))..(for-each (
10190 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 lambda (p)...
101a0 20 28 6c 65 74 2a 20 28 28 76 61 72 20 28 63 61 (let* ((var (ca
101b0 72 20 20 70 29 29 0a 09 09 09 20 20 20 28 76 61 r p)).... (va
101c0 6c 20 28 63 61 64 72 20 70 29 29 0a 09 09 09 20 l (cadr p))....
101d0 20 20 28 70 72 76 20 28 67 65 74 2d 65 6e 76 69 (prv (get-envi
101e0 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
101f0 20 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 var)))...
10200 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 (set! res (cons
10210 28 6c 69 73 74 20 76 61 72 20 70 72 76 29 20 72 (list var prv) r
10220 65 73 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 es))... (if
10230 20 76 61 6c 20 0a 09 09 09 20 20 28 73 61 66 65 val .... (safe
10240 2d 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e 73 -setenv var (->s
10250 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 tring val))....
10260 20 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 (unsetenv var))
10270 29 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 73 ))... lst)..res
10280 29 0a 20 20 20 20 20 20 27 28 29 29 29 0a 0a 3b ). '()))..;
10290 3b 20 63 6c 65 61 72 20 76 61 72 73 20 6d 61 74 ; clear vars mat
102a0 63 68 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 72 ching pattern, r
102b0 75 6e 20 70 72 6f 63 2c 20 73 65 74 20 76 61 72 un proc, set var
102c0 73 20 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 6f s back.;; if pro
102d0 63 20 69 73 20 61 20 73 74 72 69 6e 67 20 72 75 c is a string ru
102e0 6e 20 74 68 61 74 20 73 74 72 69 6e 67 20 61 73 n that string as
102f0 20 61 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 0a a command with.
10300 3b 3b 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 64 ;; system..;;.(d
10310 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 efine (common:wi
10320 74 68 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 20 thout-vars proc
10330 2e 20 76 61 72 2d 70 61 74 74 73 29 0a 20 20 28 . var-patts). (
10340 6c 65 74 20 28 28 76 61 72 73 20 28 6d 61 6b 65 let ((vars (make
10350 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 -hash-table))).
10360 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
10370 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 64 61 (lambda (varda
10380 74 29 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 76 t) ;; each env v
10390 61 72 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 ar. (for-e
103a0 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 61 ach..(lambda (va
103b0 72 2d 70 61 74 74 29 0a 09 20 20 28 69 66 20 28 r-patt).. (if (
103c0 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 72 string-match var
103d0 2d 70 61 74 74 20 28 63 61 72 20 76 61 72 64 61 -patt (car varda
103e0 74 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 t)).. (let
103f0 28 28 76 61 72 20 28 63 61 72 20 76 61 72 64 61 ((var (car varda
10400 74 29 29 0a 09 09 20 20 20 20 28 76 61 6c 20 28 t))... (val (
10410 63 64 72 20 76 61 72 64 61 74 29 29 29 0a 09 09 cdr vardat)))...
10420 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
10430 20 76 61 72 73 20 76 61 72 20 76 61 6c 29 0a 09 vars var val)..
10440 09 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 .(unsetenv var))
10450 29 29 0a 09 76 61 72 2d 70 61 74 74 73 29 29 0a ))..var-patts)).
10460 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
10470 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 nment-variables)
10480 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
10490 20 28 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 29 ((string? proc)
104a0 28 73 79 73 74 65 6d 20 70 72 6f 63 29 29 0a 20 (system proc)).
104b0 20 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 20 (proc
104c0 20 20 20 28 70 72 6f 63 29 29 29 0a 20 20 20 20 (proc))).
104d0 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d (hash-table-for-
104e0 65 61 63 68 0a 20 20 20 20 20 76 61 72 73 0a 20 each. vars.
104f0 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 (lambda (var
10500 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 val). (se
10510 74 65 6e 76 20 76 61 72 20 76 61 6c 29 29 29 0a tenv var val))).
10520 20 20 20 20 76 61 72 73 29 29 0a 0a 28 64 65 66 vars))..(def
10530 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d ine (common:run-
10540 61 2d 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 21 a-command cmd #!
10550 6b 65 79 20 28 77 69 74 68 2d 76 61 72 73 20 23 key (with-vars #
10560 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 72 f)). (let* ((pr
10570 65 2d 63 6d 64 20 20 28 64 74 65 73 74 73 3a 67 e-cmd (dtests:g
10580 65 74 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 29 et-pre-command))
10590 0a 20 20 20 20 20 20 20 20 20 28 70 6f 73 74 2d . (post-
105a0 63 6d 64 20 28 64 74 65 73 74 73 3a 67 65 74 2d cmd (dtests:get-
105b0 70 6f 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 post-command)).
105c0 20 20 20 20 20 20 20 20 28 66 75 6c 6c 63 6d 64 (fullcmd
105d0 20 20 28 69 66 20 28 6f 72 20 70 72 65 2d 63 6d (if (or pre-cm
105e0 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 d post-cmd).
105f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10600 20 20 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d 64 (conc pre-cmd
10610 20 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 cmd post-cmd).
10620 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10630 20 20 20 20 20 20 28 63 6f 6e 63 20 22 76 69 65 (conc "vie
10640 77 73 63 72 65 65 6e 20 22 20 63 6d 64 29 29 29 wscreen " cmd)))
10650 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
10660 6e 74 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 61 nt-info 02 *defa
10670 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 ult-log-port* "R
10680 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a 20 unning command:
10690 22 20 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 28 " fullcmd). (
106a0 69 66 20 77 69 74 68 2d 76 61 72 73 0a 20 20 20 if with-vars.
106b0 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 (common:wit
106c0 68 6f 75 74 2d 76 61 72 73 20 63 6d 64 29 0a 20 hout-vars cmd).
106d0 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 (common:w
106e0 69 74 68 6f 75 74 2d 76 61 72 73 20 66 75 6c 6c ithout-vars full
106f0 63 6d 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 0a cmd "MT_.*")))).
10700 09 09 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .. .;;=========
10710 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10720 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10730 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10740 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
10750 20 54 20 49 20 4d 20 45 20 20 20 41 20 4e 20 44 T I M E A N D
10760 20 20 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d 3d D A T E.;;===
10770 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10780 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10790 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107b0 3d 3d 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 ===..;; Convert
107c0 73 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 73 strings like "5s
107d0 20 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 30 2h 3m" => 60x60
107e0 78 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 64 x2 + 3x60 + 5.(d
107f0 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d efine (common:hm
10800 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 s-string->second
10810 73 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 28 s tstr). (let (
10820 28 70 61 72 74 73 20 20 20 20 20 28 73 74 72 69 (parts (stri
10830 6e 67 2d 73 70 6c 69 74 20 74 73 74 72 29 29 0a ng-split tstr)).
10840 09 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a 09 .(time-secs 0)..
10850 3b 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d ;; s=seconds, m=
10860 6d 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 73 minutes, h=hours
10870 2c 20 64 3d 64 61 79 73 0a 09 28 74 72 78 20 20 , d=days..(trx
10880 20 20 20 20 20 28 72 65 67 65 78 70 20 22 28 5c (regexp "(\
10890 5c 64 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 29 \d+)([smhd])")))
108a0 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
108b0 6c 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 09 lambda (part)...
108c0 28 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 73 (let ((match (s
108d0 74 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 20 tring-match trx
108e0 70 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 20 part)))... (if
108f0 6d 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 6c match... (l
10900 65 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e 67 et ((val (string
10910 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
10920 61 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 28 atch))).... (
10930 75 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 68 unt (caddr match
10940 29 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 0a )))....(if val .
10950 09 09 09 20 20 20 20 28 73 65 74 21 20 74 69 6d ... (set! tim
10960 65 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d 73 e-secs (+ time-s
10970 65 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 09 ecs (* val......
10980 09 09 20 20 20 20 28 63 61 73 65 20 28 73 74 72 .. (case (str
10990 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 ing->symbol unt)
109a0 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
109b0 73 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 s) 1)........
109c0 20 20 20 28 28 6d 29 20 36 30 29 0a 09 09 09 09 ((m) 60).....
109d0 09 09 09 20 20 20 20 20 20 28 28 68 29 20 28 2a ... ((h) (*
109e0 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 60 60))........
109f0 20 20 20 20 20 20 28 28 64 29 20 28 2a 20 32 34 ((d) (* 24
10a00 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 60 60))........
10a10 20 20 20 20 20 20 28 65 6c 73 65 20 30 29 29 29 (else 0)))
10a20 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 70 ))))))).. p
10a30 61 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d 73 arts). time-s
10a40 65 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 0a ecs))... .
10a50 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
10a60 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 63 ->hr-min-sec sec
10a70 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 73 s). (let* ((hrs
10a80 20 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 20 (quotient secs
10a90 33 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 71 3600)).. (min (q
10aa0 75 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 20 uotient (- secs
10ab0 28 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 30 (* hrs 3600)) 60
10ac0 29 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 63 )).. (sec (- sec
10ad0 73 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 2a s (* hrs 3600)(*
10ae0 20 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 20 min 60)))).
10af0 28 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 73 (conc (if (> hrs
10b00 20 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 72 0)(conc hrs "hr
10b10 20 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 28 ") "").. (if (
10b20 3e 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d 69 > min 0)(conc mi
10b30 6e 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 20 n "m ") "")..
10b40 73 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 66 sec "s")))..(def
10b50 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 ine (seconds->ti
10b60 6d 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a 20 me-string sec).
10b70 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a (time->string .
10b80 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
10b90 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 48 al-time sec) "%H
10ba0 3a 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 69 :%M:%S"))..(defi
10bb0 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 ne (seconds->wor
10bc0 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 k-week/day-time
10bd0 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
10be0 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
10bf0 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
10c00 29 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 4d ) "ww%V.%u %H:%M
10c10 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
10c20 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b conds->work-week
10c30 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d /day sec). (tim
10c40 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
10c50 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
10c60 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 22 e sec) "ww%V.%u"
10c70 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
10c80 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d onds->year-work-
10c90 77 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 week/day sec).
10ca0 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 (time->string.
10cb0 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
10cc0 2d 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 77 -time sec) "%yww
10cd0 25 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 6e %V.%w"))..(defin
10ce0 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 e (seconds->year
10cf0 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 -work-week/day-t
10d00 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d 65 ime sec). (time
10d10 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
10d20 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
10d30 20 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 77 sec) "%Yww%V.%w
10d40 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 %H:%M"))..(defi
10d50 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
10d60 72 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 r-week/day-time
10d70 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
10d80 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
10d90 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
10da0 29 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a 25 ) "%Yw%V.%w %H:%
10db0 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
10dc0 65 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 econds->quarter
10dd0 73 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 74 sec). (case (st
10de0 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 ring->number.. (
10df0 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 20 time->string ..
10e00 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
10e10 2d 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 25 -time sec).. "%
10e20 6d 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 33 m")). ((1 2 3
10e30 29 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 36 ) 1). ((4 5 6
10e40 29 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 39 ) 2). ((7 8 9
10e50 29 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 31 ) 3). ((10 11
10e60 20 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 73 12) 4). (els
10e70 65 20 23 66 29 29 29 0a 0a 3b 3b 20 62 61 73 69 e #f)))..;; basi
10e80 63 20 49 53 4f 38 36 30 31 20 66 6f 72 6d 61 74 c ISO8601 format
10e90 20 28 65 2e 67 2e 20 22 32 30 31 37 2d 30 32 2d (e.g. "2017-02-
10ea0 32 38 20 30 36 3a 30 32 3a 35 34 22 29 20 64 61 28 06:02:54") da
10eb0 74 65 20 74 69 6d 65 20 3d 3e 20 55 6e 69 78 20 te time => Unix
10ec0 65 70 6f 63 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 epoch.;;.(define
10ed0 20 28 63 6f 6d 6d 6f 6e 3a 64 61 74 65 2d 74 69 (common:date-ti
10ee0 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 64 61 74 65 me->seconds date
10ef0 74 69 6d 65 29 0a 20 20 28 6c 6f 63 61 6c 2d 74 time). (local-t
10f00 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 28 73 74 ime->seconds (st
10f10 72 69 6e 67 2d 3e 74 69 6d 65 20 64 61 74 65 74 ring->time datet
10f20 69 6d 65 20 22 25 59 2d 25 6d 2d 25 64 20 25 48 ime "%Y-%m-%d %H
10f30 3a 25 4d 3a 25 53 22 29 29 29 0a 0a 3b 3b 20 67 :%M:%S")))..;; g
10f40 69 76 65 6e 20 73 70 61 6e 20 6f 66 20 73 65 63 iven span of sec
10f50 6f 6e 64 73 20 74 73 74 61 72 74 20 74 6f 20 74 onds tstart to t
10f60 65 6e 64 0a 3b 3b 20 66 69 6e 64 20 73 74 61 72 end.;; find star
10f70 74 20 74 69 6d 65 20 74 6f 20 6d 61 72 6b 20 61 t time to mark a
10f80 6e 64 20 6d 61 72 6b 20 64 65 6c 74 61 0a 3b 3b nd mark delta.;;
10f90 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
10fa0 3a 66 69 6e 64 2d 73 74 61 72 74 2d 6d 61 72 6b :find-start-mark
10fb0 2d 61 6e 64 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 -and-mark-delta
10fc0 74 73 74 61 72 74 20 74 65 6e 64 29 0a 20 20 28 tstart tend). (
10fd0 6c 65 74 2a 20 28 28 64 65 6c 74 61 74 20 20 20 let* ((deltat
10fe0 28 2d 20 28 6d 61 78 20 74 65 6e 64 20 28 2b 20 (- (max tend (+
10ff0 74 65 6e 64 20 31 30 29 29 20 74 73 74 61 72 74 tend 10)) tstart
11000 29 29 20 3b 3b 20 63 61 6e 27 74 20 68 61 6e 64 )) ;; can't hand
11010 6c 65 20 72 75 6e 73 20 6f 66 20 6c 65 73 73 20 le runs of less
11020 74 68 61 6e 20 34 20 73 65 63 6f 6e 64 73 2e 20 than 4 seconds.
11030 50 61 64 20 69 74 20 74 6f 20 31 30 20 73 65 63 Pad it to 10 sec
11040 6f 6e 64 73 20 2e 2e 2e 0a 09 20 28 72 65 73 75 onds ..... (resu
11050 6c 74 20 20 20 23 66 29 0a 09 20 28 6d 69 6e 20 lt #f).. (min
11060 20 20 20 20 20 36 30 29 0a 09 20 28 68 72 20 20 60).. (hr
11070 20 20 20 20 20 28 2a 20 36 30 20 36 30 29 29 0a (* 60 60)).
11080 09 20 28 64 61 79 20 20 20 20 20 20 28 2a 20 32 . (day (* 2
11090 34 20 68 72 29 29 0a 09 20 28 79 72 20 20 20 20 4 hr)).. (yr
110a0 20 20 20 28 2a 20 33 36 35 20 64 61 79 29 29 20 (* 365 day))
110b0 3b 3b 20 79 65 61 72 0a 09 20 28 6d 6f 20 20 20 ;; year.. (mo
110c0 20 20 20 20 28 2f 20 79 72 20 31 32 29 29 0a 09 (/ yr 12))..
110d0 20 28 77 6b 20 20 20 20 20 20 20 28 2a 20 64 61 (wk (* da
110e0 79 20 37 29 29 29 0a 20 20 20 20 28 66 6f 72 2d y 7))). (for-
110f0 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
11100 61 20 28 6d 61 78 2d 62 6c 6b 73 29 0a 20 20 20 a (max-blks).
11110 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 (for-each..(
11120 6c 61 6d 62 64 61 20 28 73 70 61 6e 29 20 3b 3b lambda (span) ;;
11130 20 35 20 32 20 31 0a 09 20 20 28 69 66 20 28 6e 5 2 1.. (if (n
11140 6f 74 20 72 65 73 75 6c 74 29 0a 09 20 20 20 20 ot result)..
11150 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 (for-each ..
11160 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 69 (lambda (ti
11170 6d 65 75 6e 69 74 20 74 69 6d 65 73 79 6d 29 20 meunit timesym)
11180 3b 3b 20 79 65 61 72 20 6d 6f 6e 74 68 20 64 61 ;; year month da
11190 79 20 68 72 20 6d 69 6e 20 73 65 63 0a 09 09 20 y hr min sec...
111a0 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 29 (if (not result)
111b0 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
111c0 74 69 6d 65 2d 62 6c 6b 20 28 2a 20 73 70 61 6e time-blk (* span
111d0 20 74 69 6d 65 75 6e 69 74 29 29 0a 09 09 09 20 timeunit))....
111e0 20 20 20 28 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 (num-blks (qu
111f0 6f 74 69 65 6e 74 20 64 65 6c 74 61 74 20 74 69 otient deltat ti
11200 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 20 20 20 20 me-blk)))...
11210 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 6e (if (and (> n
11220 75 6d 2d 62 6c 6b 73 20 34 29 28 3c 20 6e 75 6d um-blks 4)(< num
11230 2d 62 6c 6b 73 20 6d 61 78 2d 62 6c 6b 73 29 29 -blks max-blks))
11240 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 66 69 .... (let ((fi
11250 72 73 74 20 28 2a 20 28 71 75 6f 74 69 65 6e 74 rst (* (quotient
11260 20 74 73 74 61 72 74 20 74 69 6d 65 2d 62 6c 6b tstart time-blk
11270 29 20 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 ) time-blk)))...
11280 09 20 20 20 20 20 28 73 65 74 21 20 72 65 73 75 . (set! resu
11290 6c 74 20 28 6c 69 73 74 20 73 70 61 6e 20 74 69 lt (list span ti
112a0 6d 65 75 6e 69 74 20 74 69 6d 65 2d 62 6c 6b 20 meunit time-blk
112b0 66 69 72 73 74 20 74 69 6d 65 73 79 6d 29 29 0a first timesym)).
112c0 09 09 09 20 20 20 20 20 29 29 29 29 29 0a 09 20 ... )))))..
112d0 20 20 20 20 20 20 28 6c 69 73 74 20 79 72 20 6d (list yr m
112e0 6f 20 77 6b 20 64 61 79 20 68 72 20 6d 69 6e 20 o wk day hr min
112f0 31 29 0a 09 20 20 20 20 20 20 20 27 28 20 20 20 1).. '(
11300 20 20 79 20 20 6d 6f 20 77 20 20 64 20 20 20 68 y mo w d h
11310 20 20 6d 20 20 20 73 29 29 29 29 0a 09 28 6c 69 m s))))..(li
11320 73 74 20 38 20 36 20 35 20 32 20 31 29 29 29 0a st 8 6 5 2 1))).
11330 20 20 20 20 20 27 28 35 20 31 30 20 31 35 20 32 '(5 10 15 2
11340 30 20 33 30 20 34 30 20 35 30 20 35 30 30 29 29 0 30 40 50 500))
11350 0a 20 20 20 20 28 69 66 20 76 61 6c 75 65 73 0a . (if values.
11360 09 28 61 70 70 6c 79 20 76 61 6c 75 65 73 20 72 .(apply values r
11370 65 73 75 6c 74 29 0a 09 28 76 61 6c 75 65 73 20 esult)..(values
11380 30 20 64 61 79 20 31 20 30 20 27 64 29 29 29 29 0 day 1 0 'd))))
11390 0a 0a 3b 3b 20 67 69 76 65 6e 20 78 20 79 20 6c ..;; given x y l
113a0 69 6d 20 72 65 74 75 72 6e 20 74 68 65 20 63 72 im return the cr
113b0 6f 6e 20 65 78 70 61 6e 73 69 6f 6e 0a 3b 3b 0a on expansion.;;.
113c0 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
113d0 65 78 70 61 6e 64 2d 63 72 6f 6e 2d 73 6c 61 73 expand-cron-slas
113e0 68 20 78 20 79 20 6c 69 6d 29 0a 20 20 28 6c 65 h x y lim). (le
113f0 74 20 6c 6f 6f 70 20 28 28 63 75 72 72 20 78 29 t loop ((curr x)
11400 0a 09 20 20 20 20 20 28 72 65 73 20 20 60 28 29 .. (res `()
11410 29 29 0a 20 20 20 20 28 69 66 20 28 3c 20 63 75 )). (if (< cu
11420 72 72 20 6c 69 6d 29 0a 09 28 6c 6f 6f 70 20 28 rr lim)..(loop (
11430 2b 20 63 75 72 72 20 79 29 20 28 63 6f 6e 73 20 + curr y) (cons
11440 63 75 72 72 20 72 65 73 29 29 0a 09 28 72 65 76 curr res))..(rev
11450 65 72 73 65 20 72 65 73 29 29 29 29 0a 0a 3b 3b erse res))))..;;
11460 20 65 78 70 61 6e 64 20 61 20 63 6f 6d 70 6c 65 expand a comple
11470 78 20 63 72 6f 6e 20 73 74 72 69 6e 67 20 74 6f x cron string to
11480 20 61 20 6c 69 73 74 20 6f 66 20 63 72 6f 6e 20 a list of cron
11490 73 74 72 69 6e 67 73 0a 3b 3b 0a 3b 3b 20 20 78 strings.;;.;; x
114a0 2f 79 20 20 20 3d 3e 20 78 2c 20 78 2b 79 2c 20 /y => x, x+y,
114b0 78 2b 32 79 2c 20 78 2b 33 79 20 77 68 69 6c 65 x+2y, x+3y while
114c0 20 78 2b 4e 79 3c 6d 61 78 5f 66 6f 72 5f 66 69 x+Ny<max_for_fi
114d0 65 6c 64 0a 3b 3b 20 20 61 2c 62 2c 63 20 3d 3e eld.;; a,b,c =>
114e0 20 61 2c 20 62 20 2c 63 0a 3b 3b 0a 3b 3b 20 20 a, b ,c.;;.;;
114f0 20 4e 4f 54 45 3a 20 77 69 74 68 20 66 6c 61 74 NOTE: with flat
11500 74 65 6e 20 61 20 6c 6f 74 20 6f 66 20 74 68 65 ten a lot of the
11510 20 63 72 75 64 20 62 65 6c 6f 77 20 63 61 6e 20 crud below can
11520 62 65 20 66 61 63 74 6f 72 65 64 20 64 6f 77 6e be factored down
11530 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ..;;.(define (co
11540 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 mmon:cron-expand
11550 20 63 72 6f 6e 2d 73 74 72 29 0a 20 20 28 69 66 cron-str). (if
11560 20 28 6c 69 73 74 3f 20 63 72 6f 6e 2d 73 74 72 (list? cron-str
11570 29 0a 20 20 20 20 20 20 28 66 6c 61 74 74 65 6e ). (flatten
11580 0a 20 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c . (fold (l
11590 61 6d 62 64 61 20 28 78 20 72 65 73 29 0a 09 20 ambda (x res)..
115a0 20 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f (if (list?
115b0 20 78 29 0a 09 09 20 20 20 28 6c 65 74 20 28 28 x)... (let ((
115c0 6e 65 77 72 65 73 20 28 6d 61 70 20 63 6f 6d 6d newres (map comm
115d0 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 78 on:cron-expand x
115e0 29 29 29 0a 09 09 20 20 20 20 20 28 61 70 70 65 )))... (appe
115f0 6e 64 20 78 20 6e 65 77 72 65 73 29 29 0a 09 09 nd x newres))...
11600 20 20 20 28 63 6f 6e 73 20 78 20 72 65 73 29 29 (cons x res))
11610 29 0a 09 20 20 20 20 20 27 28 29 0a 09 20 20 20 ).. '()..
11620 20 20 63 72 6f 6e 2d 73 74 72 29 29 20 3b 3b 20 cron-str)) ;;
11630 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e (map common:cron
11640 2d 65 78 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 -expand cron-str
11650 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 )). (let ((
11660 63 72 6f 6e 2d 69 74 65 6d 73 20 28 73 74 72 69 cron-items (stri
11670 6e 67 2d 73 70 6c 69 74 20 63 72 6f 6e 2d 73 74 ng-split cron-st
11680 72 29 29 0a 09 20 20 20 20 28 73 6c 61 73 68 2d r)).. (slash-
11690 72 78 20 20 20 28 72 65 67 65 78 70 20 22 28 5c rx (regexp "(\
116a0 5c 64 2b 29 2f 28 5c 5c 64 2b 29 22 29 29 0a 09 \d+)/(\\d+)"))..
116b0 20 20 20 20 28 63 6f 6d 6d 61 2d 72 78 20 20 20 (comma-rx
116c0 28 72 65 67 65 78 70 20 22 2e 2a 2c 2e 2a 22 29 (regexp ".*,.*")
116d0 29 0a 09 20 20 20 20 28 6d 61 78 2d 76 61 6c 73 ).. (max-vals
116e0 20 20 20 27 28 28 6d 69 6e 20 20 20 20 20 20 20 '((min
116f0 20 2e 20 36 30 29 0a 09 09 09 20 20 28 68 6f 75 . 60).... (hou
11700 72 20 20 20 20 20 20 20 2e 20 32 34 29 0a 09 09 r . 24)...
11710 09 20 20 28 64 61 79 6f 66 6d 6f 6e 74 68 20 2e . (dayofmonth .
11720 20 32 38 29 20 3b 3b 3b 20 42 55 47 21 21 21 21 28) ;;; BUG!!!!
11730 20 54 68 69 73 20 77 69 6c 6c 20 62 65 20 61 20 This will be a
11740 62 75 67 20 66 6f 72 20 73 6f 6d 65 20 63 6f 6d bug for some com
11750 62 69 6e 61 74 69 6f 6e 73 0a 09 09 09 20 20 28 binations.... (
11760 6d 6f 6e 74 68 20 20 20 20 20 20 2e 20 31 32 29 month . 12)
11770 0a 09 09 09 20 20 28 64 61 79 6f 66 77 65 65 6b .... (dayofweek
11780 20 20 2e 20 37 29 29 29 29 0a 09 28 69 66 20 28 . 7))))..(if (
11790 3c 20 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 < (length cron-i
117a0 74 65 6d 73 29 20 35 29 20 3b 3b 20 62 61 64 20 tems) 5) ;; bad
117b0 73 70 65 63 0a 09 20 20 20 20 63 72 6f 6e 2d 73 spec.. cron-s
117c0 74 72 20 3b 3b 20 60 28 2c 63 72 6f 6e 2d 73 74 tr ;; `(,cron-st
117d0 72 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r)
117e0 3b 3b 20 6a 75 73 74 20 72 65 74 75 72 6e 20 74 ;; just return t
117f0 68 65 20 73 74 72 69 6e 67 2c 20 73 6f 6d 65 74 he string, somet
11800 68 69 6e 67 20 64 6f 77 6e 73 74 72 65 61 6d 20 hing downstream
11810 77 69 6c 6c 20 66 69 78 20 69 74 0a 09 20 20 20 will fix it..
11820 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
11830 20 20 28 63 61 72 20 63 72 6f 6e 2d 69 74 65 6d (car cron-item
11840 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 s))... (ta
11850 6c 20 20 28 63 64 72 20 63 72 6f 6e 2d 69 74 65 l (cdr cron-ite
11860 6d 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 ms))... (t
11870 79 70 65 20 27 6d 69 6e 29 0a 09 09 20 20 20 20 ype 'min)...
11880 20 20 20 28 74 79 70 65 2d 74 61 6c 20 27 28 68 (type-tal '(h
11890 6f 75 72 20 64 61 79 6f 66 6d 6f 6e 74 68 20 6d our dayofmonth m
118a0 6f 6e 74 68 20 64 61 79 6f 66 77 65 65 6b 29 29 onth dayofweek))
118b0 0a 09 09 20 20 20 20 20 20 20 28 72 65 73 20 20 ... (res
118c0 27 28 29 29 29 0a 09 20 20 20 20 20 20 28 72 65 '())).. (re
118d0 67 65 78 2d 63 61 73 65 0a 09 09 20 20 68 65 64 gex-case... hed
118e0 0a 09 09 28 73 6c 61 73 68 2d 72 78 20 28 20 5f ...(slash-rx ( _
118f0 20 62 61 73 65 20 69 6e 63 72 20 29 20 28 6c 65 base incr ) (le
11900 74 2a 20 28 28 62 61 73 65 6e 20 20 20 20 20 20 t* ((basen
11910 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d (string->num
11920 62 65 72 20 62 61 73 65 29 29 0a 09 09 09 09 09 ber base))......
11930 09 20 28 69 6e 63 72 6e 20 20 20 20 20 20 20 20 . (incrn
11940 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
11950 72 20 69 6e 63 72 29 29 0a 09 09 09 09 09 09 20 r incr)).......
11960 28 65 78 70 61 6e 64 65 64 2d 76 61 6c 73 20 20 (expanded-vals
11970 28 63 6f 6d 6d 6f 6e 3a 65 78 70 61 6e 64 2d 63 (common:expand-c
11980 72 6f 6e 2d 73 6c 61 73 68 20 62 61 73 65 6e 20 ron-slash basen
11990 69 6e 63 72 6e 20 28 61 6c 69 73 74 2d 72 65 66 incrn (alist-ref
119a0 20 74 79 70 65 20 6d 61 78 2d 76 61 6c 73 29 29 type max-vals))
119b0 29 0a 09 09 09 09 09 09 20 28 6e 65 77 2d 6c 69 )....... (new-li
119c0 73 74 2d 63 72 6f 6e 73 20 28 66 6f 6c 64 20 28 st-crons (fold (
119d0 6c 61 6d 62 64 61 20 28 78 20 6d 79 72 65 73 29 lambda (x myres)
119e0 0a 09 09 09 09 09 09 09 09 09 20 28 63 6f 6e 73 .......... (cons
119f0 20 28 63 6f 6e 63 20 28 69 66 20 28 6e 75 6c 6c (conc (if (null
11a00 3f 20 72 65 73 29 0a 09 09 09 09 09 09 09 09 09 ? res)..........
11a10 09 09 20 22 22 0a 09 09 09 09 09 09 09 09 09 09 .. ""...........
11a20 09 20 28 63 6f 6e 63 20 28 73 74 72 69 6e 67 2d . (conc (string-
11a30 69 6e 74 65 72 73 70 65 72 73 65 20 72 65 73 20 intersperse res
11a40 22 20 22 29 20 22 20 22 29 29 0a 09 09 09 09 09 " ") " "))......
11a50 09 09 09 09 09 20 20 20 20 20 78 20 22 20 22 20 ..... x " "
11a60 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
11a70 72 73 65 20 74 61 6c 20 22 20 22 29 29 0a 09 09 rse tal " "))...
11a80 09 09 09 09 09 09 09 20 20 20 20 20 20 20 6d 79 ....... my
11a90 72 65 73 29 29 0a 09 09 09 09 09 09 09 09 20 20 res)).........
11aa0 20 20 20 20 20 27 28 29 20 65 78 70 61 6e 64 65 '() expande
11ab0 64 2d 76 61 6c 73 29 29 29 0a 09 09 09 09 09 20 d-vals)))......
11ac0 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6e 65 ;; (print "ne
11ad0 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 3a 20 22 20 w-list-crons: "
11ae0 6e 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 0a new-list-crons).
11af0 09 09 09 09 09 20 20 20 20 3b 3b 20 28 66 6f 6c ..... ;; (fol
11b00 64 20 28 6c 61 6d 62 64 61 20 28 78 20 72 65 73 d (lambda (x res
11b10 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 20 )...... ;; .
11b20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 78 29 (if (list? x)
11b30 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 09 28 ...... ;; ..(
11b40 6c 65 74 20 28 28 6e 65 77 72 65 73 20 28 6d 61 let ((newres (ma
11b50 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 p common:cron-ex
11b60 70 61 6e 64 20 78 29 29 29 0a 09 09 09 09 09 20 pand x)))......
11b70 20 20 20 3b 3b 20 09 09 20 20 28 61 70 70 65 6e ;; .. (appen
11b80 64 20 78 20 6e 65 77 72 65 73 29 29 0a 09 09 09 d x newres))....
11b90 09 09 20 20 20 20 3b 3b 20 09 09 28 63 6f 6e 73 .. ;; ..(cons
11ba0 20 78 20 72 65 73 29 29 29 0a 09 09 09 09 09 20 x res)))......
11bb0 20 20 20 3b 3b 20 09 20 20 27 28 29 0a 09 09 09 ;; . '()....
11bc0 09 09 20 20 20 20 28 66 6c 61 74 74 65 6e 20 28 .. (flatten (
11bd0 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d map common:cron-
11be0 65 78 70 61 6e 64 20 6e 65 77 2d 6c 69 73 74 2d expand new-list-
11bf0 63 72 6f 6e 73 29 29 29 29 0a 09 09 3b 3b 09 09 crons))))...;;..
11c00 09 09 09 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d ... (map comm
11c10 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 28 on:cron-expand (
11c20 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d map common:cron-
11c30 65 78 70 61 6e 64 20 6e 65 77 2d 6c 69 73 74 2d expand new-list-
11c40 63 72 6f 6e 73 29 29 29 29 0a 09 09 28 65 6c 73 crons))))...(els
11c50 65 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c e (if (null? tal
11c60 29 0a 09 09 09 20 20 63 72 6f 6e 2d 73 74 72 0a ).... cron-str.
11c70 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
11c80 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 61 tal)(cdr tal)(ca
11c90 72 20 74 79 70 65 2d 74 61 6c 29 28 63 64 72 20 r type-tal)(cdr
11ca0 74 79 70 65 2d 74 61 6c 29 28 61 70 70 65 6e 64 type-tal)(append
11cb0 20 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 res (list hed))
11cc0 29 29 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 )))))))))...
11cd0 20 20 0a 09 20 20 20 20 0a 3b 3b 20 67 69 76 65 .. .;; give
11ce0 6e 20 61 20 63 72 6f 6e 20 73 74 72 69 6e 67 20 n a cron string
11cf0 61 6e 64 20 74 68 65 20 6c 61 73 74 20 74 69 6d and the last tim
11d00 65 20 65 76 65 6e 74 20 77 61 73 20 70 72 6f 63 e event was proc
11d10 65 73 73 65 64 20 72 65 74 75 72 6e 20 23 74 20 essed return #t
11d20 74 6f 20 72 75 6e 20 6f 72 20 23 66 20 74 6f 20 to run or #f to
11d30 6e 6f 74 20 72 75 6e 0a 3b 3b 0a 3b 3b 20 20 6d not run.;;.;; m
11d40 69 6e 20 20 20 20 68 6f 75 72 20 20 20 64 61 79 in hour day
11d50 6f 66 6d 6f 6e 74 68 20 6d 6f 6e 74 68 20 20 64 ofmonth month d
11d60 61 79 6f 66 77 65 65 6b 0a 3b 3b 20 30 2d 35 39 ayofweek.;; 0-59
11d70 20 20 20 20 30 2d 32 33 20 20 20 31 2d 33 31 20 0-23 1-31
11d80 20 20 20 20 20 20 31 2d 31 32 20 20 20 30 2d 36 1-12 0-6
11d90 20 20 20 20 20 20 20 20 20 20 23 23 23 20 4e 4f ### NO
11da0 54 45 3a 20 64 61 79 6f 66 77 65 65 6b 20 64 6f TE: dayofweek do
11db0 65 73 20 6e 6f 74 20 69 6e 63 6c 75 64 65 20 37 es not include 7
11dc0 0a 3b 3b 0a 3b 3b 20 20 23 74 20 3d 3e 20 79 65 .;;.;; #t => ye
11dd0 73 2c 20 72 75 6e 20 74 68 65 20 6a 6f 62 0a 3b s, run the job.;
11de0 3b 20 20 23 66 20 3d 3e 20 6e 6f 2c 20 64 6f 20 ; #f => no, do
11df0 6e 6f 74 20 72 75 6e 20 74 68 65 20 6a 6f 62 0a not run the job.
11e00 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
11e10 6f 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 63 72 on:cron-event cr
11e20 6f 6e 2d 73 74 72 20 6e 6f 77 2d 73 65 63 6f 6e on-str now-secon
11e30 64 73 2d 69 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 ds-in last-done)
11e40 20 3b 3b 20 72 65 66 2d 73 65 63 6f 6e 64 73 20 ;; ref-seconds
11e50 3d 20 23 66 20 69 73 20 4e 4f 57 2e 0a 20 20 28 = #f is NOW.. (
11e60 6c 65 74 2a 20 28 28 63 72 6f 6e 2d 69 74 65 6d let* ((cron-item
11e70 73 20 20 20 20 20 28 6d 61 70 20 73 74 72 69 6e s (map strin
11e80 67 2d 3e 6e 75 6d 62 65 72 20 28 73 74 72 69 6e g->number (strin
11e90 67 2d 73 70 6c 69 74 20 63 72 6f 6e 2d 73 74 72 g-split cron-str
11ea0 29 29 29 0a 09 20 28 6e 6f 77 2d 73 65 63 6f 6e ))).. (now-secon
11eb0 64 73 20 20 20 20 28 6f 72 20 6e 6f 77 2d 73 65 ds (or now-se
11ec0 63 6f 6e 64 73 2d 69 6e 20 28 63 75 72 72 65 6e conds-in (curren
11ed0 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 28 t-seconds))).. (
11ee0 6e 6f 77 2d 74 69 6d 65 20 20 20 20 20 20 20 28 now-time (
11ef0 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
11f00 69 6d 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 ime now-seconds)
11f10 29 0a 09 20 28 6c 61 73 74 2d 64 6f 6e 65 2d 74 ).. (last-done-t
11f20 69 6d 65 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f ime (seconds->lo
11f30 63 61 6c 2d 74 69 6d 65 20 6c 61 73 74 2d 64 6f cal-time last-do
11f40 6e 65 29 29 0a 09 20 28 61 6c 6c 2d 74 69 6d 65 ne)).. (all-time
11f50 73 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 s (make-has
11f60 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 3b h-table))). ;
11f70 3b 20 28 70 72 69 6e 74 20 22 63 72 6f 6e 2d 69 ; (print "cron-i
11f80 74 65 6d 73 3a 20 22 20 63 72 6f 6e 2d 69 74 65 tems: " cron-ite
11f90 6d 73 20 22 28 6c 65 6e 67 74 68 20 63 72 6f 6e ms "(length cron
11fa0 2d 69 74 65 6d 73 29 3a 20 22 20 28 6c 65 6e 67 -items): " (leng
11fb0 74 68 20 63 72 6f 6e 2d 69 74 65 6d 73 29 29 0a th cron-items)).
11fc0 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
11fd0 3f 20 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 ? (length cron-i
11fe0 74 65 6d 73 29 20 35 29 29 20 3b 3b 20 64 6f 6e tems) 5)) ;; don
11ff0 27 74 20 65 76 65 6e 20 74 72 79 20 74 6f 20 66 't even try to f
12000 69 67 75 72 65 20 6f 75 74 20 6a 75 6e 6b 20 73 igure out junk s
12010 74 72 69 6e 67 73 0a 09 23 66 0a 09 28 6d 61 74 trings..#f..(mat
12020 63 68 2d 6c 65 74 20 28 28 28 20 20 20 20 20 63 ch-let ((( c
12030 6d 69 6e 20 63 68 6f 75 72 20 63 64 61 79 6f 66 min chour cdayof
12040 6d 6f 6e 74 68 20 63 6d 6f 6e 74 68 20 20 20 20 month cmonth
12050 63 64 61 79 6f 66 77 65 65 6b 29 0a 09 09 20 20 cdayofweek)...
12060 20 20 20 63 72 6f 6e 2d 69 74 65 6d 73 29 0a 09 cron-items)..
12070 09 20 20 20 20 3b 3b 20 30 20 20 20 20 20 31 20 . ;; 0 1
12080 20 20 20 32 20 20 20 20 20 20 20 20 33 20 20 20 2 3
12090 20 20 20 20 20 20 34 20 20 20 20 35 20 20 20 20 4 5
120a0 20 20 36 0a 09 09 20 20 20 20 28 28 6e 73 65 63 6... ((nsec
120b0 20 6e 6d 69 6e 20 6e 68 6f 75 72 20 6e 64 61 79 nmin nhour nday
120c0 6f 66 6d 6f 6e 74 68 20 6e 6d 6f 6e 74 68 20 6e ofmonth nmonth n
120d0 79 72 20 6e 64 61 79 6f 66 77 65 65 6b 20 6e 37 yr ndayofweek n7
120e0 20 6e 38 20 6e 39 29 0a 09 09 20 20 20 20 20 28 n8 n9)... (
120f0 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 6e 6f 77 vector->list now
12100 2d 74 69 6d 65 29 29 0a 09 09 20 20 20 20 28 28 -time))... ((
12110 6c 73 65 63 20 6c 6d 69 6e 20 6c 68 6f 75 72 20 lsec lmin lhour
12120 6c 64 61 79 6f 66 6d 6f 6e 74 68 20 6c 6d 6f 6e ldayofmonth lmon
12130 74 68 20 6c 79 72 20 6c 64 61 79 6f 66 77 65 65 th lyr ldayofwee
12140 6b 20 6c 37 20 6c 38 20 6c 39 29 0a 09 09 20 20 k l7 l8 l9)...
12150 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 (vector->list
12160 20 6c 61 73 74 2d 64 6f 6e 65 2d 74 69 6d 65 29 last-done-time)
12170 29 29 0a 09 20 20 3b 3b 20 63 72 65 61 74 65 20 )).. ;; create
12180 61 6c 6c 20 70 6f 73 73 69 62 6c 65 20 74 69 6d all possible tim
12190 65 20 73 6c 6f 74 73 0a 09 20 20 3b 3b 20 72 65 e slots.. ;; re
121a0 6d 6f 76 65 20 69 6e 76 61 6c 69 64 20 73 6c 6f move invalid slo
121b0 74 73 20 64 75 65 20 74 6f 20 28 66 6f 72 20 65 ts due to (for e
121c0 78 61 6d 70 6c 65 29 20 64 61 79 20 6f 66 20 77 xample) day of w
121d0 65 65 6b 0a 09 20 20 3b 3b 20 67 65 74 20 74 68 eek.. ;; get th
121e0 65 20 73 74 61 72 74 20 61 6e 64 20 65 6e 64 20 e start and end
121f0 65 6e 74 72 69 65 73 20 66 6f 72 20 74 68 65 20 entries for the
12200 72 65 66 2d 73 65 63 6f 6e 64 73 20 28 63 75 72 ref-seconds (cur
12210 72 65 6e 74 29 20 74 69 6d 65 0a 09 20 20 3b 3b rent) time.. ;;
12220 20 69 66 20 6c 61 73 74 2d 64 6f 6e 65 20 3e 20 if last-done >
12230 72 65 66 2d 73 65 63 6f 6e 64 73 20 3d 3e 20 74 ref-seconds => t
12240 68 69 73 20 69 73 20 61 6e 20 45 52 52 4f 52 21 his is an ERROR!
12250 0a 09 20 20 3b 3b 20 64 6f 65 73 20 74 68 65 20 .. ;; does the
12260 6c 61 73 74 2d 64 6f 6e 65 20 74 69 6d 65 20 66 last-done time f
12270 61 6c 6c 20 69 6e 20 74 68 65 20 6c 65 67 69 74 all in the legit
12280 20 72 65 67 69 6f 6e 3f 0a 09 20 20 3b 3b 20 20 region?.. ;;
12290 20 20 79 65 73 20 3d 3e 20 23 66 20 20 64 6f 20 yes => #f do
122a0 6e 6f 74 20 72 75 6e 20 61 67 61 69 6e 20 74 68 not run again th
122b0 69 73 20 63 6f 6d 6d 61 6e 64 0a 09 20 20 3b 3b is command.. ;;
122c0 20 20 20 20 6e 6f 20 20 3d 3e 20 23 74 20 20 6f no => #t o
122d0 6b 20 74 6f 20 72 75 6e 20 74 68 65 20 63 6f 6d k to run the com
122e0 6d 61 6e 64 0a 09 20 20 28 66 6f 72 2d 65 61 63 mand.. (for-eac
122f0 68 20 3b 3b 20 6d 6f 6e 74 68 0a 09 20 20 20 28 h ;; month.. (
12300 6c 61 6d 62 64 61 20 28 6d 6f 6e 74 68 29 0a 09 lambda (month)..
12310 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 3b (for-each ;
12320 3b 20 64 61 79 6f 66 6d 6f 6e 74 68 0a 09 20 20 ; dayofmonth..
12330 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 6f 6d (lambda (dom
12340 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 0a 09 09 )...(for-each...
12350 20 28 6c 61 6d 62 64 61 20 28 68 72 29 20 3b 3b (lambda (hr) ;;
12360 20 68 6f 75 72 0a 09 09 20 20 20 28 66 6f 72 2d hour... (for-
12370 65 61 63 68 0a 09 09 20 20 20 20 28 6c 61 6d 62 each... (lamb
12380 64 61 20 28 6d 69 6e 75 74 65 29 20 3b 3b 20 6d da (minute) ;; m
12390 69 6e 75 74 65 0a 09 09 20 20 20 20 20 20 28 6c inute... (l
123a0 65 74 20 28 28 63 6f 70 79 2d 6e 6f 77 20 28 61 et ((copy-now (a
123b0 70 70 6c 79 20 76 65 63 74 6f 72 20 28 76 65 63 pply vector (vec
123c0 74 6f 72 2d 3e 6c 69 73 74 20 6e 6f 77 2d 74 69 tor->list now-ti
123d0 6d 65 29 29 29 29 0a 09 09 09 28 76 65 63 74 6f me))))....(vecto
123e0 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 r-set! copy-now
123f0 30 20 30 29 20 3b 3b 20 66 6f 72 63 65 20 73 65 0 0) ;; force se
12400 63 6f 6e 64 73 20 74 6f 20 7a 65 72 6f 0a 09 09 conds to zero...
12410 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f .(vector-set! co
12420 70 79 2d 6e 6f 77 20 31 20 6d 69 6e 75 74 65 29 py-now 1 minute)
12430 0a 09 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 ....(vector-set!
12440 20 63 6f 70 79 2d 6e 6f 77 20 32 20 68 72 29 0a copy-now 2 hr).
12450 09 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 ...(vector-set!
12460 63 6f 70 79 2d 6e 6f 77 20 33 20 64 6f 6d 29 20 copy-now 3 dom)
12470 20 3b 3b 20 64 6f 6d 20 69 73 20 61 6c 72 65 61 ;; dom is alrea
12480 64 79 20 63 6f 72 72 65 63 74 65 64 20 66 6f 72 dy corrected for
12490 20 7a 65 72 6f 20 72 65 66 65 72 65 6e 63 65 64 zero referenced
124a0 0a 09 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 ....(vector-set!
124b0 20 63 6f 70 79 2d 6e 6f 77 20 34 20 6d 6f 6e 74 copy-now 4 mont
124c0 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 63 6f h)....(let* ((co
124d0 70 79 2d 6e 6f 77 2d 73 65 63 73 20 28 6c 6f 63 py-now-secs (loc
124e0 61 6c 2d 74 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 al-time->seconds
124f0 20 63 6f 70 79 2d 6e 6f 77 29 29 0a 09 09 09 20 copy-now))....
12500 20 20 20 20 20 20 28 6e 65 77 2d 63 6f 70 79 20 (new-copy
12510 20 20 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c (seconds->l
12520 6f 63 61 6c 2d 74 69 6d 65 20 63 6f 70 79 2d 6e ocal-time copy-n
12530 6f 77 2d 73 65 63 73 29 29 29 20 3b 3b 20 72 65 ow-secs))) ;; re
12540 6d 61 6b 65 20 74 68 65 20 74 69 6d 65 20 76 65 make the time ve
12550 63 74 6f 72 0a 09 09 09 20 20 28 69 66 20 28 6f ctor.... (if (o
12560 72 20 28 6e 6f 74 20 63 64 61 79 6f 66 77 65 65 r (not cdayofwee
12570 6b 29 0a 09 09 09 09 20 20 28 65 71 75 61 6c 3f k)..... (equal?
12580 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6e 65 77 (vector-ref new
12590 2d 63 6f 70 79 20 36 29 0a 09 09 09 09 09 20 20 -copy 6)......
125a0 63 64 61 79 6f 66 77 65 65 6b 29 29 20 3b 3b 20 cdayofweek)) ;;
125b0 69 66 20 74 68 65 20 64 61 79 20 69 73 20 73 70 if the day is sp
125c0 65 63 69 66 69 65 64 20 61 6e 64 20 61 20 6d 61 ecified and a ma
125d0 74 63 68 20 4f 52 20 69 66 20 74 68 65 20 64 61 tch OR if the da
125e0 79 20 69 73 20 4e 4f 54 20 73 70 65 63 69 66 69 y is NOT specifi
125f0 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ed.... (if
12600 28 6f 72 20 28 6e 6f 74 20 63 64 61 79 6f 66 6d (or (not cdayofm
12610 6f 6e 74 68 29 0a 09 09 09 09 20 20 20 20 20 20 onth).....
12620 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
12630 72 65 66 20 6e 65 77 2d 63 6f 70 79 20 33 29 0a ref new-copy 3).
12640 09 09 09 09 09 20 20 20 20 20 20 28 2b 20 31 20 ..... (+ 1
12650 63 64 61 79 6f 66 6d 6f 6e 74 68 29 29 29 20 3b cdayofmonth))) ;
12660 3b 20 69 66 20 74 68 65 20 6d 6f 6e 74 68 20 69 ; if the month i
12670 73 20 73 70 65 63 69 66 69 65 64 20 61 6e 64 20 s specified and
12680 61 20 6d 61 74 63 68 20 4f 52 20 69 66 20 74 68 a match OR if th
12690 65 20 6d 6f 6e 74 68 20 69 73 20 4e 4f 54 20 73 e month is NOT s
126a0 70 65 63 69 66 69 65 64 0a 09 09 09 09 20 20 28 pecified..... (
126b0 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
126c0 61 6c 6c 2d 74 69 6d 65 73 20 63 6f 70 79 2d 6e all-times copy-n
126d0 6f 77 2d 73 65 63 73 20 6e 65 77 2d 63 6f 70 79 ow-secs new-copy
126e0 29 29 29 29 29 29 0a 09 09 20 20 20 20 28 69 66 ))))))... (if
126f0 20 63 6d 69 6e 0a 09 09 09 60 28 2c 63 6d 69 6e cmin....`(,cmin
12700 29 20 20 3b 3b 20 69 66 20 67 69 76 65 6e 20 63 ) ;; if given c
12710 6d 69 6e 2c 20 68 61 76 65 20 74 6f 20 75 73 65 min, have to use
12720 20 69 74 0a 09 09 09 28 6c 69 73 74 20 28 2d 20 it....(list (-
12730 6e 6d 69 6e 20 31 29 20 6e 6d 69 6e 20 28 2b 20 nmin 1) nmin (+
12740 6e 6d 69 6e 20 31 29 29 29 29 29 20 3b 3b 20 6d nmin 1))))) ;; m
12750 69 6e 75 74 65 0a 09 09 20 28 69 66 20 63 68 6f inute... (if cho
12760 75 72 0a 09 09 20 20 20 20 20 60 28 2c 63 68 6f ur... `(,cho
12770 75 72 29 0a 09 09 20 20 20 20 20 28 6c 69 73 74 ur)... (list
12780 20 28 2d 20 6e 68 6f 75 72 20 31 29 20 6e 68 6f (- nhour 1) nho
12790 75 72 20 28 2b 20 6e 68 6f 75 72 20 31 29 29 29 ur (+ nhour 1)))
127a0 29 29 20 3b 3b 20 68 6f 75 72 0a 09 20 20 20 20 )) ;; hour..
127b0 20 20 28 69 66 20 63 64 61 79 6f 66 6d 6f 6e 74 (if cdayofmont
127c0 68 0a 09 09 20 20 60 28 2c 63 64 61 79 6f 66 6d h... `(,cdayofm
127d0 6f 6e 74 68 29 0a 09 09 20 20 28 6c 69 73 74 20 onth)... (list
127e0 28 2d 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 31 (- ndayofmonth 1
127f0 29 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 28 2b ) ndayofmonth (+
12800 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 31 29 29 ndayofmonth 1))
12810 29 29 29 0a 09 20 20 20 28 69 66 20 63 6d 6f 6e ))).. (if cmon
12820 74 68 0a 09 20 20 20 20 20 20 20 60 28 2c 63 6d th.. `(,cm
12830 6f 6e 74 68 29 0a 09 20 20 20 20 20 20 20 28 6c onth).. (l
12840 69 73 74 20 28 2d 20 6e 6d 6f 6e 74 68 20 31 29 ist (- nmonth 1)
12850 20 6e 6d 6f 6e 74 68 20 28 2b 20 6e 6d 6f 6e 74 nmonth (+ nmont
12860 68 20 31 29 29 29 29 0a 09 20 20 28 6c 65 74 20 h 1)))).. (let
12870 28 28 62 65 66 6f 72 65 20 23 66 29 0a 09 09 28 ((before #f)...(
12880 69 73 2d 69 6e 20 20 23 66 29 29 0a 09 20 20 20 is-in #f))..
12890 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 (for-each..
128a0 20 28 6c 61 6d 62 64 61 20 28 6d 6f 6d 65 6e 74 (lambda (moment
128b0 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 61 ).. (if (a
128c0 6e 64 20 62 65 66 6f 72 65 0a 09 09 09 28 3c 3d nd before....(<=
128d0 20 62 65 66 6f 72 65 20 6e 6f 77 2d 73 65 63 6f before now-seco
128e0 6e 64 73 29 0a 09 09 09 28 3e 3d 20 6d 6f 6d 65 nds)....(>= mome
128f0 6e 74 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 29 nt now-seconds))
12900 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 ... (begin...
12910 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 29 0a 09 ;; (print)..
12920 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 . ;; (print
12930 22 42 65 66 6f 72 65 3a 20 22 20 28 74 69 6d 65 "Before: " (time
12940 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 ->string (second
12950 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 62 65 s->local-time be
12960 66 6f 72 65 29 29 29 0a 09 09 20 20 20 20 20 3b fore)))... ;
12970 3b 20 28 70 72 69 6e 74 20 22 4e 6f 77 3a 20 20 ; (print "Now:
12980 20 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e " (time->strin
12990 67 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 g (seconds->loca
129a0 6c 2d 74 69 6d 65 20 6e 6f 77 2d 73 65 63 6f 6e l-time now-secon
129b0 64 73 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 ds)))... ;;
129c0 28 70 72 69 6e 74 20 22 41 66 74 65 72 3a 20 20 (print "After:
129d0 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
129e0 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
129f0 74 69 6d 65 20 6d 6f 6d 65 6e 74 29 29 29 0a 09 time moment)))..
12a00 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 . ;; (print
12a10 22 4c 61 73 74 3a 20 20 20 22 20 28 74 69 6d 65 "Last: " (time
12a20 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 ->string (second
12a30 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6c 61 s->local-time la
12a40 73 74 2d 64 6f 6e 65 29 29 29 0a 09 09 20 20 20 st-done)))...
12a50 20 20 28 69 66 20 28 3c 20 20 6c 61 73 74 2d 64 (if (< last-d
12a60 6f 6e 65 20 62 65 66 6f 72 65 29 0a 09 09 09 20 one before)....
12a70 28 73 65 74 21 20 69 73 2d 69 6e 20 62 65 66 6f (set! is-in befo
12a80 72 65 29 29 0a 09 09 20 20 20 20 20 29 29 0a 09 re))... ))..
12a90 20 20 20 20 20 20 20 28 73 65 74 21 20 62 65 66 (set! bef
12aa0 6f 72 65 20 6d 6f 6d 65 6e 74 29 29 0a 09 20 20 ore moment))..
12ab0 20 20 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 (sort (hash-t
12ac0 61 62 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 69 able-keys all-ti
12ad0 6d 65 73 29 20 3c 29 29 0a 09 20 20 20 20 69 73 mes) <)).. is
12ae0 2d 69 6e 29 29 29 29 29 0a 0a 28 64 65 66 69 6e -in)))))..(defin
12af0 65 20 28 63 6f 6d 6d 6f 6e 3a 65 78 74 65 6e 64 e (common:extend
12b00 65 64 2d 63 72 6f 6e 20 20 63 72 6f 6e 2d 73 74 ed-cron cron-st
12b10 72 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e r now-seconds-in
12b20 20 6c 61 73 74 2d 64 6f 6e 65 29 0a 20 20 28 6c last-done). (l
12b30 65 74 20 28 28 65 78 70 61 6e 64 65 64 2d 63 72 et ((expanded-cr
12b40 6f 6e 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d on (common:cron-
12b50 65 78 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 29 expand cron-str)
12b60 29 29 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 )). (if (stri
12b70 6e 67 3f 20 65 78 70 61 6e 64 65 64 2d 63 72 6f ng? expanded-cro
12b80 6e 29 0a 09 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e n)..(common:cron
12b90 2d 65 76 65 6e 74 20 65 78 70 61 6e 64 65 64 2d -event expanded-
12ba0 63 72 6f 6e 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 cron now-seconds
12bb0 2d 69 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 0a 09 -in last-done)..
12bc0 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
12bd0 28 63 61 72 20 65 78 70 61 6e 64 65 64 2d 63 72 (car expanded-cr
12be0 6f 6e 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 on))... (tal (
12bf0 63 64 72 20 65 78 70 61 6e 64 65 64 2d 63 72 6f cdr expanded-cro
12c00 6e 29 29 29 0a 09 20 20 28 69 66 20 28 63 6f 6d n))).. (if (com
12c10 6d 6f 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 68 mon:cron-event h
12c20 65 64 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 ed now-seconds-i
12c30 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 0a 09 20 20 n last-done)..
12c40 20 20 20 20 23 74 0a 09 20 20 20 20 20 20 28 69 #t.. (i
12c50 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
12c60 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 #f... (loop (
12c70 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
12c80 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ))))))))..;;====
12c90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12ca0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12cb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12cc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12cd0 3d 3d 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 ==.;; C O L O R
12ce0 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
12cf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 ==========.
12d30 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f .(define (commo
12d40 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f n:name->iup-colo
12d50 72 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 r name). (case
12d60 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
12d70 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
12d80 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 name)). ((re
12d90 64 29 20 20 20 20 22 32 32 33 20 33 33 20 34 39 d) "223 33 49
12da0 22 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 "). ((grey)
12db0 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 0a "192 192 192").
12dc0 20 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 ((orange) "2
12dd0 35 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 55 172 13").
12de0 28 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 ((purple) "This
12df0 69 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e is unfinished ..
12e00 2e 22 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e .")))..;; (defin
12e10 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
12e20 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 lor-for-state-st
12e30 61 74 75 73 20 73 74 61 74 65 20 73 74 61 74 75 atus state statu
12e40 73 29 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 s).;; (case (s
12e50 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
12e60 61 74 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f ate).;; ((CO
12e70 4d 50 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 MPLETED).;;
12e80 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
12e90 73 79 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b symbol status).;
12ea0 3b 20 20 20 20 20 20 20 20 28 28 50 41 53 53 29 ; ((PASS)
12eb0 20 20 20 20 20 20 20 20 22 37 30 20 20 32 34 39 "70 249
12ec0 20 37 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 73").;;
12ed0 28 28 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 ((WARN WAIVED) "
12ee0 32 35 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 255 172 13").;;
12ef0 20 20 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 ((SKIP)
12f00 20 20 20 20 20 20 22 32 33 30 20 32 33 30 20 30 "230 230 0
12f10 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c ").;; (el
12f20 73 65 20 22 32 32 33 20 33 33 20 34 39 22 29 29 se "223 33 49"))
12f30 29 0a 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 ).;; ((LAUNC
12f40 48 45 44 29 20 20 20 20 20 20 20 20 20 22 31 30 HED) "10
12f50 31 20 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 1 123 142").;;
12f60 20 20 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 ((CHECK)
12f70 20 20 20 20 20 20 20 22 32 35 35 20 31 30 30 20 "255 100
12f80 35 30 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 50").;; ((RE
12f90 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 MOTEHOSTSTART)
12fa0 22 35 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b "50 130 195").;
12fb0 3b 20 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 ; ((RUNNING)
12fc0 20 20 20 20 20 20 20 20 20 20 22 39 20 20 20 31 "9 1
12fd0 33 31 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 31 232").;;
12fe0 28 28 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 ((KILLREQ)
12ff0 20 20 20 20 22 33 39 20 20 38 32 20 20 32 30 36 "39 82 206
13000 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c ").;; ((KILL
13010 45 44 29 20 20 20 20 20 20 20 20 20 20 20 22 32 ED) "2
13020 33 34 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 34 101 17").;;
13030 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 ((NOT_STARTED
13040 29 20 20 20 20 20 20 22 32 34 30 20 32 34 30 20 ) "240 240
13050 32 34 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 240").;; (el
13060 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
13070 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 29 "192 192 192"))
13080 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
13090 6f 6e 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 on:iup-color->rg
130a0 62 2d 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 b-hex instr). (
130b0 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
130c0 73 65 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d se . (map (lam
130d0 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 bda (x).
130e0 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e (number->strin
130f0 67 20 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 g x 16)).
13100 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 (map string->nu
13110 6d 62 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 mber.
13120 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
13130 69 6e 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 instr))). "/")
13140 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
13150 6f 6e 3a 66 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 on:faux-lock key
13160 6e 61 6d 65 20 23 21 6b 65 79 20 28 77 61 69 74 name #!key (wait
13170 2d 74 69 6d 65 20 38 29 29 0a 20 20 28 69 66 20 -time 8)). (if
13180 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (rmt:no-sync-get
13190 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 /default keyname
131a0 20 23 66 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 62 #f) ;; do not b
131b0 65 20 74 65 6d 70 74 65 64 20 74 6f 20 63 6f 6d e tempted to com
131c0 70 61 72 65 20 74 6f 20 70 69 64 2e 20 6c 6f 63 pare to pid. loc
131d0 6b 69 6e 67 20 69 73 20 61 20 6f 6e 65 2d 73 68 king is a one-sh
131e0 6f 74 20 61 63 74 69 6f 6e 2c 20 69 66 20 61 6c ot action, if al
131f0 72 65 61 64 79 20 6c 6f 63 6b 65 64 20 66 6f 72 ready locked for
13200 20 74 68 69 73 20 70 69 64 20 69 74 20 64 6f 65 this pid it doe
13210 73 6e 27 74 20 61 63 74 75 61 6c 6c 79 20 63 6f sn't actually co
13220 75 6e 74 0a 20 20 20 20 20 20 28 69 66 20 28 3e unt. (if (>
13230 20 77 61 69 74 2d 74 69 6d 65 20 30 29 0a 09 20 wait-time 0)..
13240 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 74 68 (begin.. (th
13250 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 read-sleep! 1)..
13260 20 20 20 20 28 69 66 20 28 65 71 3f 20 77 61 69 (if (eq? wai
13270 74 2d 74 69 6d 65 20 31 29 20 3b 3b 20 6f 6e 6c t-time 1) ;; onl
13280 79 20 6f 6e 65 20 73 65 63 6f 6e 64 20 6c 65 66 y one second lef
13290 74 2c 20 73 74 65 61 6c 20 74 68 65 20 6c 6f 63 t, steal the loc
132a0 6b 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 k...(begin... (
132b0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
132c0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
132d0 70 6f 72 74 2a 20 22 73 74 65 61 6c 69 6e 67 20 port* "stealing
132e0 6c 6f 63 6b 20 66 6f 72 20 22 20 6b 65 79 6e 61 lock for " keyna
132f0 6d 65 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a me)... (common:
13300 66 61 75 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e faux-unlock keyn
13310 61 6d 65 20 66 6f 72 63 65 3a 20 23 74 29 29 29 ame force: #t)))
13320 0a 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 .. (common:fa
13330 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 ux-lock keyname
13340 77 61 69 74 2d 74 69 6d 65 3a 20 28 2d 20 77 61 wait-time: (- wa
13350 69 74 2d 74 69 6d 65 20 31 29 29 29 0a 09 20 20 it-time 1)))..
13360 23 66 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e #f). (begin
13370 0a 20 20 20 20 20 20 20 20 28 72 6d 74 3a 6e 6f . (rmt:no
13380 2d 73 79 6e 63 2d 73 65 74 20 6b 65 79 6e 61 6d -sync-set keynam
13390 65 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 e (conc (current
133a0 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 20 -process-id))).
133b0 20 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 (equal? (
133c0 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 conc (current-pr
133d0 6f 63 65 73 73 2d 69 64 29 29 20 28 63 6f 6e 63 ocess-id)) (conc
133e0 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 (rmt:no-sync-ge
133f0 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d t/default keynam
13400 65 20 23 66 29 29 29 29 29 29 0a 0a 28 64 65 66 e #f))))))..(def
13410 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 75 78 ine (common:faux
13420 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 -unlock keyname
13430 23 21 6b 65 79 20 28 66 6f 72 63 65 20 23 66 29 #!key (force #f)
13440 29 0a 20 20 28 69 66 20 28 6f 72 20 66 6f 72 63 ). (if (or forc
13450 65 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 63 20 e (equal? (conc
13460 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
13470 2d 69 64 29 29 20 28 63 6f 6e 63 20 28 72 6d 74 -id)) (conc (rmt
13480 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 :no-sync-get/def
13490 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 29 ault keyname #f)
134a0 29 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e ))). (begin
134b0 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 72 6d . (if (rm
134c0 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 t:no-sync-get/de
134d0 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 fault keyname #f
134e0 29 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 64 ) (rmt:no-sync-d
134f0 65 6c 21 20 6b 65 79 6e 61 6d 65 29 29 0a 20 20 el! keyname)).
13500 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 #t).
13510 23 66 29 29 0a 0a 20 20 0a 28 64 65 66 69 6e 65 #f)).. .(define
13520 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e (common:in-runn
13530 69 6e 67 2d 74 65 73 74 3f 29 0a 20 20 28 61 6e ing-test?). (an
13540 64 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 d (args:get-arg
13550 22 2d 65 78 65 63 75 74 65 22 29 20 28 67 65 74 "-execute") (get
13560 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
13570 69 61 62 6c 65 20 22 4d 54 5f 43 4d 44 49 4e 46 iable "MT_CMDINF
13580 4f 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 O")))..(define (
13590 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
135a0 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
135b0 74 75 73 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 tus). (cond.
135c0 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
135d0 22 50 41 53 53 22 29 20 20 20 20 22 67 72 65 65 "PASS") "gree
135e0 6e 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 n"). ((equal?
135f0 73 74 61 74 75 73 20 22 46 41 49 4c 22 29 20 20 status "FAIL")
13600 20 20 22 72 65 64 22 29 0a 20 20 20 28 28 65 71 "red"). ((eq
13610 75 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 52 ual? status "WAR
13620 4e 22 29 20 20 20 20 22 6f 72 61 6e 67 65 22 29 N") "orange")
13630 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
13640 74 75 73 20 22 4b 49 4c 4c 45 44 22 29 20 20 22 tus "KILLED") "
13650 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 orange"). ((eq
13660 75 61 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c ual? status "KIL
13670 4c 52 45 51 22 29 20 22 70 75 72 70 6c 65 22 29 LREQ") "purple")
13680 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
13690 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 29 20 22 tus "RUNNING") "
136a0 62 6c 75 65 22 29 0a 20 20 20 28 28 65 71 75 61 blue"). ((equa
136b0 6c 3f 20 73 74 61 74 75 73 20 22 41 42 4f 52 54 l? status "ABORT
136c0 22 29 20 20 20 22 62 72 6f 77 6e 22 29 0a 20 20 ") "brown").
136d0 20 28 65 6c 73 65 20 22 62 6c 61 63 6b 22 29 29 (else "black"))
136e0 29 0a 0a 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d )..;; ;;========
136f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13700 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13710 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13720 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
13730 3b 20 3b 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 ; ;; N A N O M S
13740 20 47 20 20 20 43 20 4c 20 49 20 45 20 4e 20 54 G C L I E N T
13750 0a 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;; ;;==========
13760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13770 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13780 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13790 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
137a0 0a 3b 3b 20 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 .;; .;; .;; (def
137b0 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 ine (common:send
137c0 2d 64 62 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 -dboard-main-cha
137d0 6e 67 65 64 29 0a 3b 3b 20 20 20 28 6c 65 74 2a nged).;; (let*
137e0 20 28 28 64 61 73 68 62 6f 61 72 64 2d 69 70 73 ((dashboard-ips
137f0 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 (mddb:get-dashb
13800 6f 61 72 64 73 29 29 29 0a 3b 3b 20 20 20 20 20 oards))).;;
13810 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 (for-each.;;
13820 20 20 28 6c 61 6d 62 64 61 20 28 69 70 61 64 72 (lambda (ipadr
13830 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 6c 65 74 ).;; (let
13840 2a 20 28 28 73 6f 63 20 28 63 6f 6d 6d 6f 6e 3a * ((soc (common:
13850 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 6f 6e open-nm-req (con
13860 63 20 22 74 63 70 3a 2f 2f 22 20 69 70 61 64 72 c "tcp://" ipadr
13870 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 6d ))).;; . (m
13880 73 67 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 22 sg (conc "main "
13890 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 3b 3b 20 *toppath*)).;;
138a0 09 20 20 20 20 20 20 28 72 65 73 20 28 63 6f 6d . (res (com
138b0 6d 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 63 65 mon:nm-send-rece
138c0 69 76 65 2d 74 69 6d 65 6f 75 74 20 73 6f 63 20 ive-timeout soc
138d0 6d 73 67 29 29 29 0a 3b 3b 20 09 20 28 69 66 20 msg))).;; . (if
138e0 28 6e 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f 75 (not res) ;; cou
138f0 6c 64 6e 27 74 20 72 65 61 63 68 20 74 68 61 74 ldn't reach that
13900 20 64 61 73 68 62 6f 61 72 64 20 2d 20 72 65 6d dashboard - rem
13910 6f 76 65 20 69 74 20 66 72 6f 6d 20 64 62 0a 3b ove it from db.;
13920 3b 20 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ; . (print "
13930 45 52 52 4f 52 3a 20 63 6f 75 6c 64 6e 27 74 20 ERROR: couldn't
13940 72 65 61 63 68 20 64 61 73 68 62 6f 61 72 64 20 reach dashboard
13950 22 20 69 70 61 64 72 29 29 0a 3b 3b 20 09 20 72 " ipadr)).;; . r
13960 65 73 29 29 0a 3b 3b 20 20 20 20 20 20 64 61 73 es)).;; das
13970 68 62 6f 61 72 64 2d 69 70 73 29 29 29 0a 3b 3b hboard-ips))).;;
13980 20 20 20 20 20 0a 3b 3b 20 20 20 20 20 0a 3b 3b .;; .;;
13990 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
139a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
139d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 3b 3b 20 =========.;; ;;
139e0 44 20 41 20 53 20 48 20 42 20 4f 20 41 20 52 20 D A S H B O A R
139f0 44 20 20 20 44 20 42 20 0a 3b 3b 20 3b 3b 3d 3d D D B .;; ;;==
13a00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a40 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 ====.;; .;; (def
13a50 69 6e 65 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 ine (mddb:open-d
13a60 62 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 b).;; (let* ((
13a70 64 62 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 db (open-databas
13a80 65 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 e (conc (get-env
13a90 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
13aa0 65 20 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 e "HOME") "/.das
13ab0 68 62 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 3b hboard.db")))).;
13ac0 3b 20 20 20 20 20 28 73 65 74 2d 62 75 73 79 2d ; (set-busy-
13ad0 68 61 6e 64 6c 65 72 21 20 64 62 20 28 62 75 73 handler! db (bus
13ae0 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 30 29 y-timeout 10000)
13af0 29 0a 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 ).;; (for-ea
13b00 63 68 0a 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 ch.;; (lamb
13b10 64 61 20 28 71 72 79 29 0a 3b 3b 20 20 20 20 20 da (qry).;;
13b20 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 (exec (sql db
13b30 20 71 72 79 29 29 29 0a 3b 3b 20 20 20 20 20 20 qry))).;;
13b40 28 6c 69 73 74 20 0a 3b 3b 20 20 20 20 20 20 20 (list .;;
13b50 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 "CREATE TABLE IF
13b60 20 4e 4f 54 20 45 58 49 53 54 53 20 76 61 72 73 NOT EXISTS vars
13b70 20 20 20 20 20 20 20 28 69 64 20 49 4e 54 45 47 (id INTEG
13b80 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b ER PRIMARY KEY,k
13b90 65 79 20 54 45 58 54 2c 20 76 61 6c 20 54 45 58 ey TEXT, val TEX
13ba0 54 2c 20 43 4f 4e 53 54 52 41 49 4e 54 20 76 61 T, CONSTRAINT va
13bb0 72 73 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 rsconstraint UNI
13bc0 51 55 45 20 28 6b 65 79 29 29 3b 22 0a 3b 3b 20 QUE (key));".;;
13bd0 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 "CREATE TA
13be0 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 BLE IF NOT EXIST
13bf0 53 20 64 61 73 68 62 6f 61 72 64 73 20 28 0a 3b S dashboards (.;
13c00 3b 20 20 20 20 20 20 20 20 20 20 20 69 64 20 20 ; id
13c10 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 INTEGER P
13c20 52 49 4d 41 52 59 20 4b 45 59 2c 0a 3b 3b 20 20 RIMARY KEY,.;;
13c30 20 20 20 20 20 20 20 20 20 70 69 64 20 20 20 20 pid
13c40 20 20 20 20 49 4e 54 45 47 45 52 2c 0a 3b 3b 20 INTEGER,.;;
13c50 20 20 20 20 20 20 20 20 20 20 75 73 65 72 6e 61 userna
13c60 6d 65 20 20 20 54 45 58 54 2c 0a 3b 3b 20 20 20 me TEXT,.;;
13c70 20 20 20 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 hostname
13c80 20 20 20 54 45 58 54 2c 0a 3b 3b 20 20 20 20 20 TEXT,.;;
13c90 20 20 20 20 20 20 69 70 61 64 64 72 20 20 20 20 ipaddr
13ca0 20 54 45 58 54 2c 0a 3b 3b 20 20 20 20 20 20 20 TEXT,.;;
13cb0 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 20 20 49 portnum I
13cc0 4e 54 45 47 45 52 2c 0a 3b 3b 20 20 20 20 20 20 NTEGER,.;;
13cd0 20 20 20 20 20 73 74 61 72 74 5f 74 69 6d 65 20 start_time
13ce0 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 55 4c TIMESTAMP DEFAUL
13cf0 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 T (strftime('%s'
13d00 2c 27 6e 6f 77 27 29 29 2c 0a 3b 3b 20 20 20 20 ,'now')),.;;
13d10 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 CONSTR
13d20 41 49 4e 54 20 68 6f 73 74 70 6f 72 74 20 55 4e AINT hostport UN
13d30 49 51 55 45 20 28 68 6f 73 74 6e 61 6d 65 2c 70 IQUE (hostname,p
13d40 6f 72 74 6e 75 6d 29 0a 3b 3b 20 20 20 20 20 20 ortnum).;;
13d50 20 20 20 29 3b 22 0a 3b 3b 20 20 20 20 20 20 20 );".;;
13d60 29 29 0a 3b 3b 20 20 20 20 20 64 62 29 29 0a 3b )).;; db)).;
13d70 3b 20 0a 3b 3b 20 3b 3b 20 72 65 67 69 73 74 65 ; .;; ;; registe
13d80 72 20 61 20 64 61 73 68 62 6f 61 72 64 20 0a 3b r a dashboard .;
13d90 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ; ;;.;; (define
13da0 28 6d 64 64 62 3a 72 65 67 69 73 74 65 72 2d 64 (mddb:register-d
13db0 61 73 68 62 6f 61 72 64 20 70 6f 72 74 29 0a 3b ashboard port).;
13dc0 3b 20 20 20 28 6c 65 74 2a 20 28 28 70 69 64 20 ; (let* ((pid
13dd0 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 (current-pr
13de0 6f 63 65 73 73 2d 69 64 29 29 0a 3b 3b 20 09 20 ocess-id)).;; .
13df0 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 (hostname (get-h
13e00 6f 73 74 2d 6e 61 6d 65 29 29 0a 3b 3b 20 09 20 ost-name)).;; .
13e10 28 69 70 61 64 64 72 20 20 20 28 73 65 72 76 65 (ipaddr (serve
13e20 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 r:get-best-guess
13e30 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d -address hostnam
13e40 65 29 29 0a 3b 3b 20 09 20 28 75 73 65 72 6e 61 e)).;; . (userna
13e50 6d 65 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 me (current-user
13e60 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 61 72 20 -name)) ;; (car
13e70 75 73 65 72 69 6e 66 6f 29 29 29 0a 3b 3b 20 09 userinfo))).;; .
13e80 20 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a (db (mddb:
13e90 6f 70 65 6e 2d 64 62 29 29 29 0a 3b 3b 20 20 20 open-db))).;;
13ea0 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 (print "Regist
13eb0 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 69 64 3a er monitor, pid:
13ec0 20 22 20 70 69 64 20 22 2c 20 68 6f 73 74 6e 61 " pid ", hostna
13ed0 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 me: " hostname "
13ee0 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 74 20 22 , port: " port "
13ef0 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 20 75 73 , username: " us
13f00 65 72 6e 61 6d 65 29 0a 3b 3b 20 20 20 20 20 28 ername).;; (
13f10 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 49 4e exec (sql db "IN
13f20 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
13f30 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 64 73 20 INTO dashboards
13f40 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 2c 68 6f (pid,username,ho
13f50 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 2c 70 6f stname,ipaddr,po
13f60 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 20 28 3f rtnum) VALUES (?
13f70 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 3b 3b 20 ,?,?,?,?);").;;
13f80 09 20 20 20 70 69 64 20 75 73 65 72 6e 61 6d 65 . pid username
13f90 20 68 6f 73 74 6e 61 6d 65 20 69 70 61 64 64 72 hostname ipaddr
13fa0 20 70 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 63 port).;; (c
13fb0 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 20 64 62 lose-database db
13fc0 29 29 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 75 6e ))).;; .;; ;; un
13fd0 72 65 67 69 73 74 65 72 20 61 20 6d 6f 6e 69 74 register a monit
13fe0 6f 72 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 or.;; ;;.;; (def
13ff0 69 6e 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 69 ine (mddb:unregi
14000 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 68 ster-dashboard h
14010 6f 73 74 20 70 6f 72 74 29 0a 3b 3b 20 20 20 28 ost port).;; (
14020 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 28 let* ((db (
14030 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a mddb:open-db))).
14040 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 52 ;; (print "R
14050 65 67 69 73 74 65 72 20 75 6e 72 65 67 69 73 74 egister unregist
14060 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 74 er monitor, host
14070 3a 70 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a 22 :port=" host ":"
14080 20 70 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 65 port).;; (e
14090 78 65 63 20 28 73 71 6c 20 64 62 20 22 44 45 4c xec (sql db "DEL
140a0 45 54 45 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 ETE FROM dashboa
140b0 72 64 73 20 57 48 45 52 45 20 68 6f 73 74 6e 61 rds WHERE hostna
140c0 6d 65 3d 3f 20 41 4e 44 20 70 6f 72 74 6e 75 6d me=? AND portnum
140d0 3d 3f 3b 22 29 20 68 6f 73 74 20 70 6f 72 74 29 =?;") host port)
140e0 0a 3b 3b 20 20 20 20 20 28 63 6c 6f 73 65 2d 64 .;; (close-d
140f0 61 74 61 62 61 73 65 20 64 62 29 29 29 0a 3b 3b atabase db))).;;
14100 20 0a 3b 3b 20 3b 3b 20 67 65 74 20 72 65 67 69 .;; ;; get regi
14110 73 74 65 72 65 64 20 64 61 73 68 62 6f 61 72 64 stered dashboard
14120 73 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 s.;; ;;.;; (defi
14130 6e 65 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 ne (mddb:get-das
14140 68 62 6f 61 72 64 73 29 0a 3b 3b 20 20 20 28 6c hboards).;; (l
14150 65 74 20 28 28 64 62 20 28 6d 64 64 62 3a 6f 70 et ((db (mddb:op
14160 65 6e 2d 64 62 29 29 29 0a 3b 3b 20 20 20 20 20 en-db))).;;
14170 28 71 75 65 72 79 20 66 65 74 63 68 2d 63 6f 6c (query fetch-col
14180 75 6d 6e 0a 3b 3b 20 09 20 20 20 28 73 71 6c 20 umn.;; . (sql
14190 64 62 20 22 53 45 4c 45 43 54 20 69 70 61 64 64 db "SELECT ipadd
141a0 72 20 7c 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 r || ':' || port
141b0 6e 75 6d 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 num FROM dashboa
141c0 72 64 73 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b rds;")))). .;
141d0 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
141e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
141f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14210 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 =======.;; T E
14220 53 20 54 20 20 20 4c 20 41 20 55 20 4e 20 43 20 S T L A U N C
14230 48 20 49 20 4e 20 47 20 20 20 50 20 45 20 52 20 H I N G P E R
14240 20 20 49 20 54 20 45 20 4d 20 20 20 57 20 49 20 I T E M W I
14250 54 20 48 20 20 20 48 20 4f 20 53 20 54 20 20 20 T H H O S T
14260 54 20 59 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d T Y P E S.;;====
14270 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14280 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14290 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142b0 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 ==.;; .;; [hosts
142c0 5d 0a 3b 3b 20 61 72 6d 20 63 75 62 69 65 30 31 ].;; arm cubie01
142d0 20 63 75 62 69 65 30 32 0a 3b 3b 20 78 38 36 5f cubie02.;; x86_
142e0 36 34 20 7a 65 75 73 20 78 65 6e 61 20 6d 79 74 64 zeus xena myt
142f0 68 30 31 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 20 h01.;; allhosts
14300 23 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 20 23 #{g hosts arm} #
14310 7b 67 20 68 6f 73 74 73 20 78 38 36 5f 36 34 7d {g hosts x86_64}
14320 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 .;; .;; [host-ty
14330 70 65 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 pes].;; general
14340 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b #MTLOWESTLOAD #{
14350 67 20 68 6f 73 74 73 20 61 6c 6c 68 6f 73 74 73 g hosts allhosts
14360 7d 0a 3b 3b 20 61 72 6d 20 20 20 20 20 23 4d 54 }.;; arm #MT
14370 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 LOWESTLOAD #{g h
14380 6f 73 74 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 67 osts arm}.;; nbg
14390 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e eneral nbjob run
143a0 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 JOBCOMMAND -log
143b0 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d $MT_LINKTREE/$M
143c0 54 5f 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e T_TARGET/$MT_RUN
143d0 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d NAME.$MT_TESTNAM
143e0 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e E-$MT_ITEM_PATH.
143f0 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e lgo.;; .;; [laun
14400 63 68 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 chers].;; envset
14410 75 70 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f up general.;; xo
14420 72 2f 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 r/%/n 4C16G.;; %
14430 20 6e 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b nbgeneral.;; .;
14440 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 ; [jobtools].;;
14450 23 20 69 66 20 64 65 66 69 6e 65 64 20 61 6e 64 # if defined and
14460 20 6e 6f 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d not "no" flexi-
14470 6c 61 75 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 launcher will by
14480 70 61 73 73 20 22 6c 61 75 6e 63 68 65 72 22 20 pass "launcher"
14490 75 6e 6c 65 73 73 20 6e 6f 20 6d 61 74 63 68 2e unless no match.
144a0 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 .;; flexi-launch
144b0 65 72 20 79 65 73 20 20 0a 3b 3b 20 6c 61 75 6e er yes .;; laun
144c0 63 68 65 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a 28 cher nbfake.;;.(
144d0 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
144e0 65 74 2d 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 et-launcher conf
144f0 69 67 64 61 74 20 74 65 73 74 6e 61 6d 65 20 69 igdat testname i
14500 74 65 6d 70 61 74 68 29 0a 20 20 28 6c 65 74 20 tempath). (let
14510 28 28 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 ((fallback-launc
14520 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f her (configf:loo
14530 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a kup configdat "j
14540 6f 62 74 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 obtools" "launch
14550 65 72 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 er"))). (if (
14560 61 6e 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f and (configf:loo
14570 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a kup configdat "j
14580 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d obtools" "flexi-
14590 6c 61 75 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 launcher") ;; ov
145a0 65 72 72 69 64 65 73 20 6c 61 75 6e 63 68 65 72 errides launcher
145b0 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 .. (not (equ
145c0 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f al? (configf:loo
145d0 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a kup configdat "j
145e0 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d obtools" "flexi-
145f0 6c 61 75 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 launcher") "no")
14600 29 29 0a 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e ))..(let* ((laun
14610 63 68 65 72 73 20 20 20 20 20 20 20 20 20 28 68 chers (h
14620 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
14630 66 61 75 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 fault configdat
14640 22 6c 61 75 6e 63 68 65 72 73 22 20 27 28 29 29 "launchers" '())
14650 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f )).. (if (null?
14660 20 6c 61 75 6e 63 68 65 72 73 29 0a 09 20 20 20 launchers)..
14670 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e fallback-laun
14680 63 68 65 72 0a 09 20 20 20 20 20 20 28 6c 65 74 cher.. (let
14690 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
146a0 20 6c 61 75 6e 63 68 65 72 73 29 29 0a 09 09 09 launchers))....
146b0 20 28 74 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 (tal (cdr launc
146c0 68 65 72 73 29 29 29 0a 09 09 28 6c 65 74 20 28 hers)))...(let (
146d0 28 70 61 74 74 20 20 20 20 20 20 28 63 61 72 20 (patt (car
146e0 68 65 64 29 29 0a 09 09 20 20 20 20 20 20 28 68 hed))... (h
146f0 6f 73 74 2d 74 79 70 65 20 28 63 61 64 72 20 68 ost-type (cadr h
14700 65 64 29 29 29 0a 09 09 20 20 28 69 66 20 28 74 ed)))... (if (t
14710 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 74 20 ests:match patt
14720 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 testname itempat
14730 68 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 h)... (begi
14740 6e 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e n....(debug:prin
14750 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
14760 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 t-log-port* "Hav
14770 65 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 e flexi-launcher
14780 20 6d 61 74 63 68 20 66 6f 72 20 22 20 74 65 73 match for " tes
14790 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 tname "/" itempa
147a0 74 68 20 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 th " = " host-ty
147b0 70 65 29 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 pe)....(let ((la
147c0 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a uncher (configf:
147d0 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
147e0 20 22 68 6f 73 74 2d 74 79 70 65 73 22 20 68 6f "host-types" ho
147f0 73 74 2d 74 79 70 65 29 29 29 0a 09 09 09 20 20 st-type)))....
14800 28 69 66 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 (if launcher....
14810 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 (let* ((la
14820 75 6e 63 68 65 72 2d 70 61 72 74 73 20 28 73 74 uncher-parts (st
14830 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 ring-split launc
14840 68 65 72 29 29 0a 09 09 09 09 20 20 20 20 20 28 her))..... (
14850 6c 61 75 6e 63 68 65 72 2d 65 78 65 20 20 20 28 launcher-exe (
14860 63 61 72 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 car launcher-par
14870 74 73 29 29 29 0a 09 09 09 09 28 69 66 20 28 65 ts))).....(if (e
14880 71 75 61 6c 3f 20 6c 61 75 6e 63 68 65 72 2d 65 qual? launcher-e
14890 78 65 20 22 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 xe "#MTLOWESTLOA
148a0 44 22 29 20 3b 3b 20 74 68 69 73 20 69 73 20 6f D") ;; this is o
148b0 75 72 20 73 70 65 63 69 61 6c 20 63 61 73 65 2c ur special case,
148c0 20 77 65 20 77 69 6c 6c 20 66 69 6e 64 20 74 68 we will find th
148d0 65 20 6c 6f 77 65 73 74 20 6c 6f 61 64 20 61 6e e lowest load an
148e0 64 20 63 72 61 66 74 20 61 20 6e 62 66 61 6b 65 d craft a nbfake
148f0 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 09 commandline....
14900 09 20 20 20 20 28 6c 65 74 20 28 28 74 61 72 67 . (let ((targ
14910 2d 68 6f 73 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -host (common:ge
14920 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 t-least-loaded-h
14930 6f 73 74 20 28 63 64 72 20 6c 61 75 6e 63 68 65 ost (cdr launche
14940 72 2d 70 61 72 74 73 29 29 29 29 0a 09 09 09 09 r-parts)))).....
14950 20 20 20 20 20 20 28 63 6f 6e 63 20 22 72 65 6d (conc "rem
14960 72 75 6e 20 22 20 74 61 72 67 2d 68 6f 73 74 29 run " targ-host)
14970 29 0a 09 09 09 09 20 20 20 20 6c 61 75 6e 63 68 )..... launch
14980 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 er)).... (b
14990 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a egin.....(debug:
149a0 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
149b0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
149c0 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 "WARNING: no lau
149d0 6e 63 68 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 ncher found for
149e0 68 6f 73 74 2d 74 79 70 65 20 22 20 68 6f 73 74 host-type " host
149f0 2d 74 79 70 65 29 0a 09 09 09 09 28 69 66 20 28 -type).....(if (
14a00 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 null? tal).....
14a10 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e fallback-laun
14a20 63 68 65 72 0a 09 09 09 09 20 20 20 20 28 6c 6f cher..... (lo
14a30 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
14a40 20 74 61 6c 29 29 29 29 29 29 29 0a 09 09 20 20 tal)))))))...
14a50 20 20 20 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c ;; no match,
14a60 20 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 try again...
14a70 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
14a80 6c 29 0a 09 09 09 20 20 66 61 6c 6c 62 61 63 6b l).... fallback
14a90 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 28 -launcher.... (
14aa0 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
14ab0 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 dr tal))))))))..
14ac0 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
14ad0 72 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d r))). .;;======
14ae0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14af0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b20 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 .;; D A S H B O
14b30 41 20 52 20 44 20 20 20 55 20 53 20 45 20 52 20 A R D U S E R
14b40 20 20 56 20 49 20 45 20 57 20 53 0a 3b 3b 3d 3d V I E W S.;;==
14b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b90 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 72 73 74 20 72 ====..;; first r
14ba0 65 61 64 20 7e 2f 76 69 65 77 73 2e 63 6f 6e 66 ead ~/views.conf
14bb0 69 67 20 69 66 20 69 74 20 65 78 69 73 74 73 2c ig if it exists,
14bc0 20 74 68 65 6e 20 72 65 61 64 20 24 4d 54 52 41 then read $MTRA
14bd0 48 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 H/views.config i
14be0 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 0a 28 f it exists.;;.(
14bf0 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
14c00 6f 61 64 2d 76 69 65 77 73 2d 63 6f 6e 66 69 67 oad-views-config
14c10 29 0a 20 20 28 6c 65 74 2a 20 28 28 76 69 65 77 ). (let* ((view
14c20 2d 63 66 67 64 61 74 20 20 20 20 28 6d 61 6b 65 -cfgdat (make
14c30 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 -hash-table))..
14c40 28 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 20 20 (home-cfgfile
14c50 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 (conc (get-envir
14c60 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
14c70 22 48 4f 4d 45 22 29 20 22 2f 2e 6d 74 76 69 65 "HOME") "/.mtvie
14c80 77 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 ws.config")).. (
14c90 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 28 mthome-cfgfile (
14ca0 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
14cb0 2f 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 /.mtviews.config
14cc0 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f "))). (if (co
14cd0 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
14ce0 3f 20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 ? mthome-cfgfile
14cf0 29 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 )..(read-config
14d00 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 mthome-cfgfile v
14d10 69 65 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a iew-cfgdat #t)).
14d20 20 20 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 ;; we load t
14d30 68 65 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 he home dir file
14d40 20 41 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 AFTER the MTRAH
14d50 20 66 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 file so the use
14d60 72 20 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 r can clobber se
14d70 74 74 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e ttings when runn
14d80 69 6e 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 ing the dashboar
14d90 64 20 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 d in read-only a
14da0 72 65 61 73 0a 20 20 20 20 28 69 66 20 28 63 6f reas. (if (co
14db0 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
14dc0 3f 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a ? home-cfgfile).
14dd0 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 68 6f .(read-config ho
14de0 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 77 2d me-cfgfile view-
14df0 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 20 20 cfgdat #t)).
14e00 76 69 65 77 2d 63 66 67 64 61 74 29 29 0a 0a 3b view-cfgdat))..;
14e10 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
14e20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e50 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 61 6e 61 67 =======.;; Manag
14e60 65 20 70 6b 74 73 2c 20 75 73 65 64 20 69 6e 20 e pkts, used in
14e70 73 65 72 76 65 72 73 2c 20 74 65 73 74 73 20 61 servers, tests a
14e80 6e 64 20 6c 69 6b 65 6c 79 20 6f 74 68 65 72 20 nd likely other
14e90 63 6f 6e 74 65 78 74 73 20 73 6f 20 70 75 74 0a contexts so put.
14ea0 3b 3b 20 69 6e 20 63 6f 6d 6d 6f 6e 0a 3b 3b 3d ;; in common.;;=
14eb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ec0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ed0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ee0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ef0 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 63 =====..(define c
14f00 6f 6d 6d 6f 6e 3a 70 6b 74 2d 73 70 65 63 0a 20 ommon:pkt-spec.
14f10 20 27 28 28 73 65 72 76 65 72 20 2e 20 28 28 61 '((server . ((a
14f20 63 74 69 6f 6e 20 20 20 20 2e 20 61 29 0a 09 20 ction . a)..
14f30 20 20 20 20 20 20 28 70 69 64 20 20 20 20 20 20 (pid
14f40 20 2e 20 64 29 0a 09 20 20 20 20 20 20 20 28 69 . d).. (i
14f50 70 61 64 64 72 20 20 20 20 2e 20 69 29 0a 09 20 paddr . i)..
14f60 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 (port
14f70 20 2e 20 70 29 29 29 0a 20 20 20 20 09 09 09 20 . p))). ...
14f80 20 0a 20 20 20 20 28 74 65 73 74 20 20 20 2e 20 . (test .
14f90 28 28 63 70 75 75 73 65 20 20 20 20 2e 20 63 29 ((cpuuse . c)
14fa0 0a 09 20 20 20 20 20 20 20 28 64 69 73 6b 75 73 .. (diskus
14fb0 65 20 20 20 2e 20 64 29 0a 09 20 20 20 20 20 20 e . d)..
14fc0 20 28 69 74 65 6d 2d 70 61 74 68 20 2e 20 69 29 (item-path . i)
14fd0 0a 09 20 20 20 20 20 20 20 28 72 75 6e 6e 61 6d .. (runnam
14fe0 65 20 20 20 2e 20 72 29 0a 09 20 20 20 20 20 20 e . r)..
14ff0 20 28 73 74 61 74 65 20 20 20 20 20 2e 20 73 29 (state . s)
15000 0a 09 20 20 20 20 20 20 20 28 74 61 72 67 65 74 .. (target
15010 20 20 20 20 2e 20 74 29 0a 09 20 20 20 20 20 20 . t)..
15020 20 28 73 74 61 74 75 73 20 20 20 20 2e 20 75 29 (status . u)
15030 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
15040 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 73 2d 64 ommon:get-pkts-d
15050 69 72 73 20 6d 74 63 6f 6e 66 20 75 73 65 2d 6c irs mtconf use-l
15060 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 6b 74 t). (let* ((pkt
15070 73 64 69 72 73 2d 73 74 72 20 28 6f 72 20 28 63 sdirs-str (or (c
15080 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 onfigf:lookup mt
15090 63 6f 6e 66 20 22 73 65 74 75 70 22 20 20 22 70 conf "setup" "p
150a0 6b 74 73 64 69 72 73 22 29 0a 09 09 09 20 20 20 ktsdirs")....
150b0 28 61 6e 64 20 75 73 65 2d 6c 74 0a 09 09 09 09 (and use-lt.....
150c0 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
150d0 22 2f 6c 74 2f 2e 70 6b 74 73 22 29 29 29 29 0a "/lt/.pkts")))).
150e0 09 20 28 70 6b 74 73 64 69 72 73 20 20 28 69 66 . (pktsdirs (if
150f0 20 70 6b 74 73 64 69 72 73 2d 73 74 72 0a 09 09 pktsdirs-str...
15100 09 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 .(string-split p
15110 6b 74 73 64 69 72 73 2d 73 74 72 20 22 20 22 29 ktsdirs-str " ")
15120 0a 09 09 09 23 66 29 29 29 0a 20 20 20 20 70 6b ....#f))). pk
15130 74 73 64 69 72 73 29 29 0a 0a 3b 3b 20 75 73 65 tsdirs))..;; use
15140 2d 6c 74 20 69 73 20 75 73 65 20 6c 69 6e 6b 74 -lt is use linkt
15150 72 65 65 20 22 6c 74 22 20 6c 69 6e 6b 20 74 6f ree "lt" link to
15160 20 66 69 6e 64 20 70 6b 74 73 20 64 69 72 0a 28 find pkts dir.(
15170 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
15180 69 74 68 2d 71 75 65 75 65 2d 64 62 20 6d 74 63 ith-queue-db mtc
15190 6f 6e 66 20 70 72 6f 63 20 23 21 6b 65 79 20 28 onf proc #!key (
151a0 75 73 65 2d 6c 74 20 23 66 29 28 74 6f 70 70 61 use-lt #f)(toppa
151b0 74 68 2d 69 6e 20 23 66 29 29 0a 20 20 28 6c 65 th-in #f)). (le
151c0 74 2a 20 28 28 70 6b 74 73 64 69 72 73 20 28 63 t* ((pktsdirs (c
151d0 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 73 2d 64 ommon:get-pkts-d
151e0 69 72 73 20 6d 74 63 6f 6e 66 20 75 73 65 2d 6c irs mtconf use-l
151f0 74 29 29 0a 09 20 28 70 6b 74 73 64 69 72 20 20 t)).. (pktsdir
15200 28 69 66 20 70 6b 74 73 64 69 72 73 20 28 63 61 (if pktsdirs (ca
15210 72 20 70 6b 74 73 64 69 72 73 29 20 23 66 29 29 r pktsdirs) #f))
15220 0a 09 20 28 74 6f 70 70 61 74 68 20 20 28 6f 72 .. (toppath (or
15230 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
15240 20 6d 74 63 6f 6e 66 20 22 73 63 72 61 74 63 68 mtconf "scratch
15250 64 61 74 22 20 22 74 6f 70 70 61 74 68 22 29 0a dat" "toppath").
15260 09 09 20 20 20 20 20 20 20 74 6f 70 70 61 74 68 .. toppath
15270 2d 69 6e 29 29 0a 09 20 28 70 64 62 70 61 74 68 -in)).. (pdbpath
15280 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c (or (configf:l
15290 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 73 65 ookup mtconf "se
152a0 74 75 70 22 20 20 22 70 64 62 70 61 74 68 22 29 tup" "pdbpath")
152b0 20 70 6b 74 73 64 69 72 29 29 29 0a 20 20 20 20 pktsdir))).
152c0 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 (cond. ((not
152d0 20 28 61 6e 64 20 20 70 6b 74 73 64 69 72 20 74 (and pktsdir t
152e0 6f 70 70 61 74 68 20 70 64 62 70 61 74 68 29 29 oppath pdbpath))
152f0 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
15300 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
15310 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
15320 20 73 65 74 74 69 6e 67 73 20 61 72 65 20 6d 69 settings are mi
15330 73 73 69 6e 67 20 69 6e 20 79 6f 75 72 20 6d 65 ssing in your me
15340 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 66 6f gatest.config fo
15350 72 20 61 72 65 61 20 6d 61 6e 61 67 65 6d 65 6e r area managemen
15360 74 2e 22 29 0a 20 20 20 20 20 20 28 64 65 62 75 t."). (debu
15370 67 3a 70 72 69 6e 74 20 20 30 20 2a 64 65 66 61 g:print 0 *defa
15380 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
15390 20 79 6f 75 20 6e 65 65 64 20 74 6f 20 68 61 76 you need to hav
153a0 65 20 70 6b 74 73 64 69 72 20 69 6e 20 74 68 65 e pktsdir in the
153b0 20 5b 73 65 74 75 70 5d 20 73 65 63 74 69 6f 6e [setup] section
153c0 2e 22 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 .")). ((not
153d0 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
153e0 73 74 73 3f 20 70 6b 74 73 64 69 72 29 29 0a 20 sts? pktsdir)).
153f0 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
15400 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
15410 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 70 -port* "ERROR: p
15420 6b 74 73 20 64 69 72 65 63 74 6f 72 79 20 6e 6f kts directory no
15430 74 20 66 6f 75 6e 64 20 22 20 70 6b 74 73 64 69 t found " pktsdi
15440 72 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 r)). ((not (
15450 65 71 75 61 6c 3f 20 28 66 69 6c 65 2d 6f 77 6e equal? (file-own
15460 65 72 20 70 6b 74 73 64 69 72 29 28 63 75 72 72 er pktsdir)(curr
15470 65 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 ent-effective-us
15480 65 72 2d 69 64 29 29 29 0a 20 20 20 20 20 20 28 er-id))). (
15490 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
154a0 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
154b0 20 22 45 52 52 4f 52 3a 20 64 69 72 65 63 74 6f "ERROR: directo
154c0 72 79 20 22 20 70 6b 74 73 64 69 72 20 22 20 69 ry " pktsdir " i
154d0 73 20 6e 6f 74 20 6f 77 6e 65 64 20 62 79 20 22 s not owned by "
154e0 20 28 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 (current-effect
154f0 69 76 65 2d 75 73 65 72 2d 6e 61 6d 65 29 29 29 ive-user-name)))
15500 0a 20 20 20 20 20 28 65 6c 73 65 0a 09 28 6c 65 . (else..(le
15510 74 2a 20 28 28 70 64 62 20 20 28 6f 70 65 6e 2d t* ((pdb (open-
15520 71 75 65 75 65 2d 64 62 20 70 64 62 70 61 74 68 queue-db pdbpath
15530 20 22 70 6b 74 73 2e 64 62 22 0a 09 09 09 09 20 "pkts.db".....
15540 20 20 20 73 63 68 65 6d 61 3a 20 27 28 22 43 52 schema: '("CR
15550 45 41 54 45 20 54 41 42 4c 45 20 67 72 6f 75 70 EATE TABLE group
15560 73 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 s (id INTEGER PR
15570 49 4d 41 52 59 20 4b 45 59 2c 67 72 6f 75 70 6e IMARY KEY,groupn
15580 61 6d 65 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 ame TEXT, CONSTR
15590 41 49 4e 54 20 67 72 6f 75 70 5f 63 6f 6e 73 74 AINT group_const
155a0 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 67 72 raint UNIQUE (gr
155b0 6f 75 70 6e 61 6d 65 29 29 3b 22 29 29 29 29 0a oupname));")))).
155c0 09 20 20 28 70 72 6f 63 20 70 6b 74 73 64 69 72 . (proc pktsdir
155d0 73 20 70 6b 74 73 64 69 72 20 70 64 62 29 0a 09 s pktsdir pdb)..
155e0 20 20 28 64 62 69 3a 63 6c 6f 73 65 20 70 64 62 (dbi:close pdb
155f0 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
15600 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 64 2d 70 6b 74 (common:load-pkt
15610 73 2d 74 6f 2d 64 62 20 6d 74 63 6f 6e 66 29 0a s-to-db mtconf).
15620 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d 71 (common:with-q
15630 75 65 75 65 2d 64 62 0a 20 20 20 6d 74 63 6f 6e ueue-db. mtcon
15640 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 70 6b f. (lambda (pk
15650 74 73 64 69 72 73 20 70 6b 74 73 64 69 72 20 70 tsdirs pktsdir p
15660 64 62 29 0a 20 20 20 20 20 28 66 6f 72 2d 65 61 db). (for-ea
15670 63 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ch. (lambda
15680 20 28 70 6b 74 73 64 69 72 29 20 3b 3b 20 6c 6f (pktsdir) ;; lo
15690 6f 6b 20 61 74 20 61 6c 6c 0a 09 28 63 6f 6e 64 ok at all..(cond
156a0 0a 09 20 28 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e .. ((not (common
156b0 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 6b :file-exists? pk
156c0 74 73 64 69 72 29 29 0a 09 20 20 28 64 65 62 75 tsdir)).. (debu
156d0 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
156e0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
156f0 52 4f 52 3a 20 70 61 63 6b 65 74 73 20 64 69 72 ROR: packets dir
15700 65 63 74 6f 72 79 20 22 20 70 6b 74 73 64 69 72 ectory " pktsdir
15710 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 " does not exis
15720 74 2e 22 29 29 0a 09 20 28 28 6e 6f 74 20 28 64 t.")).. ((not (d
15730 69 72 65 63 74 6f 72 79 3f 20 70 6b 74 73 64 69 irectory? pktsdi
15740 72 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 r)).. (debug:pr
15750 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
15760 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a og-port* "ERROR:
15770 20 70 61 63 6b 65 74 73 20 64 69 72 65 63 74 6f packets directo
15780 72 79 20 70 61 74 68 20 22 20 70 6b 74 73 64 69 ry path " pktsdi
15790 72 20 22 20 69 73 20 6e 6f 74 20 61 20 64 69 72 r " is not a dir
157a0 65 63 74 6f 72 79 2e 22 29 29 0a 09 20 28 28 6e ectory.")).. ((n
157b0 6f 74 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 ot (file-read-ac
157c0 63 65 73 73 3f 20 70 6b 74 73 64 69 72 29 29 0a cess? pktsdir)).
157d0 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
157e0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
157f0 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 70 61 63 ort* "ERROR: pac
15800 6b 65 74 73 20 64 69 72 65 63 74 6f 72 79 20 70 kets directory p
15810 61 74 68 20 22 20 70 6b 74 73 64 69 72 20 22 20 ath " pktsdir "
15820 69 73 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 2e is not readable.
15830 22 29 29 0a 09 20 28 65 6c 73 65 0a 09 20 20 28 ")).. (else.. (
15840 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
15850 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
15860 70 6f 72 74 2a 20 22 4c 6f 61 64 69 6e 67 20 70 port* "Loading p
15870 61 63 6b 65 74 73 20 66 6f 75 6e 64 20 69 6e 20 ackets found in
15880 22 20 70 6b 74 73 64 69 72 29 0a 09 20 20 28 6c " pktsdir).. (l
15890 65 74 20 28 28 70 6b 74 73 20 28 67 6c 6f 62 20 et ((pkts (glob
158a0 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 2f (conc pktsdir "/
158b0 2a 2e 70 6b 74 22 29 29 29 29 0a 09 20 20 20 20 *.pkt"))))..
158c0 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 (for-each..
158d0 28 6c 61 6d 62 64 61 20 28 70 6b 74 29 0a 09 20 (lambda (pkt)..
158e0 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 75 75 (let* ((uu
158f0 69 64 20 20 20 20 28 63 61 64 72 20 28 73 74 72 id (cadr (str
15900 69 6e 67 2d 6d 61 74 63 68 20 22 2e 2a 2f 28 5b ing-match ".*/([
15910 30 2d 39 61 2d 66 5d 2b 29 2e 70 6b 74 22 20 70 0-9a-f]+).pkt" p
15920 6b 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 65 kt)))... (e
15930 78 69 73 74 73 20 20 28 6c 6f 6f 6b 75 70 2d 62 xists (lookup-b
15940 79 2d 75 75 69 64 20 70 64 62 20 75 75 69 64 20 y-uuid pdb uuid
15950 23 66 29 29 29 0a 09 09 20 28 69 66 20 28 6e 6f #f)))... (if (no
15960 74 20 65 78 69 73 74 73 29 0a 09 09 20 20 20 20 t exists)...
15970 20 28 6c 65 74 2a 20 28 28 70 6b 74 64 61 74 20 (let* ((pktdat
15980 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
15990 72 73 65 0a 09 09 09 09 20 20 20 20 20 28 77 69 rse..... (wi
159a0 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 th-input-from-fi
159b0 6c 65 20 70 6b 74 20 72 65 61 64 2d 6c 69 6e 65 le pkt read-line
159c0 73 29 0a 09 09 09 09 20 20 20 20 20 22 5c 6e 22 s)..... "\n"
159d0 29 29 0a 09 09 09 20 20 20 20 28 61 70 6b 74 20 )).... (apkt
159e0 20 20 28 70 6b 74 2d 3e 61 6c 69 73 74 20 70 6b (pkt->alist pk
159f0 74 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 70 tdat)).... (p
15a00 74 79 70 65 20 20 28 61 6c 69 73 74 2d 72 65 66 type (alist-ref
15a10 20 27 54 20 61 70 6b 74 29 29 29 0a 09 09 20 20 'T apkt)))...
15a20 20 20 20 20 20 28 61 64 64 2d 74 6f 2d 71 75 65 (add-to-que
15a30 75 65 20 70 64 62 20 70 6b 74 64 61 74 20 75 75 ue pdb pktdat uu
15a40 69 64 20 28 6f 72 20 70 74 79 70 65 20 27 63 6d id (or ptype 'cm
15a50 64 29 20 23 66 20 30 29 0a 09 09 20 20 20 20 20 d) #f 0)...
15a60 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
15a70 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
15a80 72 74 2a 20 22 41 64 64 65 64 20 22 20 75 75 69 rt* "Added " uui
15a90 64 20 22 20 6f 66 20 74 79 70 65 20 22 20 70 74 d " of type " pt
15aa0 79 70 65 20 22 20 74 6f 20 71 75 65 75 65 22 29 ype " to queue")
15ab0 29 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a )... (debug:
15ac0 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 print 4 *default
15ad0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 6b 74 3a -log-port* "pkt:
15ae0 20 22 20 75 75 69 64 20 22 20 65 78 69 73 74 73 " uuid " exists
15af0 2c 20 73 6b 69 70 70 69 6e 67 2e 2e 2e 22 29 0a , skipping...").
15b00 09 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 .. )))..
15b10 20 70 6b 74 73 29 29 29 29 29 0a 20 20 20 20 20 pkts))))).
15b20 20 70 6b 74 73 64 69 72 73 29 29 29 29 0a 0a 28 pktsdirs))))..(
15b30 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
15b40 65 74 2d 70 6b 74 2d 61 6c 69 73 74 73 20 70 6b et-pkt-alists pk
15b50 74 73 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 ts). (map (lamb
15b60 64 61 20 28 78 29 0a 09 20 28 61 6c 69 73 74 2d da (x).. (alist-
15b70 72 65 66 20 27 61 70 6b 74 20 78 29 29 20 3b 3b ref 'apkt x)) ;;
15b80 20 27 70 6b 74 61 20 70 75 6c 6c 73 20 6f 75 74 'pkta pulls out
15b90 20 74 68 65 20 61 6c 69 73 74 20 66 72 6f 6d 20 the alist from
15ba0 74 68 65 20 72 65 61 64 20 70 6b 74 0a 20 20 20 the read pkt.
15bb0 20 20 20 20 70 6b 74 73 29 29 0a 0a 3b 3b 20 67 pkts))..;; g
15bc0 69 76 65 6e 20 6c 69 73 74 20 6f 66 20 70 6b 74 iven list of pkt
15bd0 73 20 28 61 6c 69 73 74 20 6d 6f 64 65 29 20 72 s (alist mode) r
15be0 65 74 75 72 6e 20 6c 69 73 74 20 6f 66 20 44 20 eturn list of D
15bf0 63 61 72 64 73 20 61 73 20 55 6e 69 78 20 65 70 cards as Unix ep
15c00 6f 63 68 2c 20 73 6f 72 74 65 64 20 64 65 73 63 och, sorted desc
15c10 65 6e 64 69 6e 67 0a 3b 3b 20 61 6c 73 6f 20 64 ending.;; also d
15c20 65 6c 65 74 65 20 64 75 70 6c 69 63 61 74 65 73 elete duplicates
15c30 20 62 79 20 74 61 72 67 65 74 20 69 2e 65 2e 20 by target i.e.
15c40 28 63 61 72 20 70 6b 74 29 0a 3b 3b 0a 28 64 65 (car pkt).;;.(de
15c50 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
15c60 2d 70 6b 74 2d 74 69 6d 65 73 20 70 6b 74 73 29 -pkt-times pkts)
15c70 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 . (delete-dupli
15c80 63 61 74 65 73 0a 20 20 20 28 73 6f 72 74 20 0a cates. (sort .
15c90 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
15ca0 20 28 78 29 0a 09 20 20 20 60 28 2c 28 61 6c 69 (x).. `(,(ali
15cb0 73 74 2d 72 65 66 20 27 74 20 78 29 20 2e 20 2c st-ref 't x) . ,
15cc0 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
15cd0 28 61 6c 69 73 74 2d 72 65 66 20 27 44 20 78 29 (alist-ref 'D x)
15ce0 29 29 29 0a 09 20 70 6b 74 73 29 0a 20 20 20 20 ))).. pkts).
15cf0 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 3e 20 (lambda (a b)(>
15d00 28 63 64 72 20 61 29 28 63 64 72 20 62 29 29 29 (cdr a)(cdr b)))
15d10 29 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 20 64 ) ;; sort d
15d20 65 73 63 65 6e 64 69 6e 67 0a 20 20 20 28 6c 61 escending. (la
15d30 6d 62 64 61 20 28 61 20 62 29 28 65 71 75 61 6c mbda (a b)(equal
15d40 3f 20 28 63 61 72 20 61 29 28 63 61 72 20 62 29 ? (car a)(car b)
15d50 29 29 29 29 20 3b 3b 20 72 65 6d 6f 76 65 20 64 )))) ;; remove d
15d60 75 70 6c 69 63 61 74 65 73 20 62 79 20 74 61 72 uplicates by tar
15d70 67 65 74 0a 0a 0a 0a get....