0000: 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 36 ; Copyright 2006
0010: 2d 32 30 31 37 2c 20 4d 61 74 74 68 65 77 20 57 -2017, Matthew W
0020: 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 54 elland..;; .;; T
0030: 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 74 his file is part
0040: 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a 3b 3b of Megatest..;;
0050: 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 .;; Megates
0060: 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 77 61 t is free softwa
0070: 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 64 69 re: you can redi
0080: 73 74 72 69 62 75 74 65 20 69 74 20 61 6e 64 2f stribute it and/
0090: 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 20 20 or modify.;;
00a0: 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 74 65 it under the te
00b0: 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 20 47 rms of the GNU G
00c0: 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 eneral Public Li
00d0: 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 73 68 cense as publish
00e0: 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 68 65 ed by.;; the
00f0: 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 20 46 Free Software F
0100: 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 68 65 oundation, eithe
0110: 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 20 74 r version 3 of t
0120: 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 0a 3b he License, or.;
0130: 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 20 6f ; (at your o
0140: 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 65 72 ption) any later
0150: 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a 3b 3b version..;; .;;
0160: 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 Megatest is
0170: 20 64 69 73 74 72 69 62 75 74 65 64 20 69 6e 20 distributed in
0180: 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 69 74 the hope that it
0190: 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 6c 2c will be useful,
01a0: 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 54 48 .;; but WITH
01b0: 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 OUT ANY WARRANTY
01c0: 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 ; without even t
01d0: 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 72 61 he implied warra
01e0: 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 4d 45 nty of.;; ME
01f0: 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 6f 72 RCHANTABILITY or
0200: 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 50 FITNESS FOR A P
0210: 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f 53 ARTICULAR PURPOS
0220: 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b 20 20 E. See the.;;
0230: 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 GNU General P
0240: 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 66 6f ublic License fo
0250: 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 2e 0a r more details..
0260: 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 20 73 ;; .;; You s
0270: 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 65 69 hould have recei
0280: 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 74 68 ved a copy of th
0290: 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 e GNU General Pu
02a0: 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b 3b 20 blic License.;;
02b0: 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 20 4d along with M
02c0: 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e 6f 74 egatest. If not
02d0: 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f 77 77 , see <http://ww
02e0: 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 6e 73 w.gnu.org/licens
02f0: 65 73 2f 3e 2e 0a 3b 3b 0a 0a 3b 3b 20 28 69 6e es/>..;;..;; (in
0300: 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 2e 73 63 clude "common.sc
0310: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6d 65 m").(include "me
0320: 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 2e 73 gatest-version.s
0330: 63 6d 22 29 0a 0a 3b 3b 20 66 61 6b 65 20 6f 75 cm")..;; fake ou
0340: 74 20 72 65 61 64 6c 69 6e 65 20 75 73 61 67 65 t readline usage
0350: 20 6f 66 20 74 6f 70 6c 65 76 65 6c 2d 63 6f 6d of toplevel-com
0360: 6d 61 6e 64 0a 28 64 65 66 69 6e 65 20 28 74 6f mand.(define (to
0370: 70 6c 65 76 65 6c 2d 63 6f 6d 6d 61 6e 64 20 2e plevel-command .
0380: 20 61 29 20 23 66 29 0a 0a 28 75 73 65 20 73 72 a) #f)..(use sr
0390: 66 69 2d 31 20 70 6f 73 69 78 20 73 72 66 69 2d fi-1 posix srfi-
03a0: 36 39 20 72 65 61 64 6c 69 6e 65 20 3b 3b 20 20 69 readline ;;
03b0: 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 regex regex-case
03c0: 20 73 72 66 69 2d 36 39 20 61 70 72 6f 70 6f 73 srfi-69 apropos
03d0: 20 6a 73 6f 6e 20 68 74 74 70 2d 63 6c 69 65 6e json http-clien
03e0: 74 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c t directory-util
03f0: 73 20 72 70 63 20 74 79 70 65 64 2d 72 65 63 6f s rpc typed-reco
0400: 72 64 73 3b 3b 20 28 73 72 66 69 20 31 38 29 20 rds;; (srfi 18)
0410: 65 78 74 72 61 73 29 0a 20 20 20 73 72 66 69 2d extras). srfi-
0420: 31 39 20 20 73 72 66 69 2d 31 38 20 65 78 74 72 19 srfi-18 extr
0430: 61 73 20 66 6f 72 6d 61 74 20 70 6b 74 73 20 72 as format pkts r
0440: 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 0a egex regex-case.
0450: 20 20 20 20 20 28 70 72 65 66 69 78 20 64 62 69 (prefix dbi
0460: 20 64 62 69 3a 29 0a 20 20 20 20 20 28 70 72 65 dbi:). (pre
0470: 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 fix sqlite3 sqli
0480: 74 65 33 3a 29 0a 20 20 20 20 20 6e 61 6e 6f 6d te3:). nanom
0490: 73 67 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 sg)..(declare (u
04a0: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
04b0: 63 6c 61 72 65 20 28 75 73 65 73 20 6d 61 72 67 clare (uses marg
04c0: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
04d0: 65 73 20 63 6f 6e 66 69 67 66 29 29 0a 3b 3b 20 es configf)).;;
04e0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 (declare (uses r
04f0: 6d 74 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 mt))..(declare (
0500: 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 uses commonmod))
0510: 0a 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e 6d .(import commonm
0520: 6f 64 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 od)..(declare (u
0530: 73 65 73 20 63 6f 6e 66 69 67 66 6d 6f 64 29 29 ses configfmod))
0540: 0a 28 69 6d 70 6f 72 74 20 63 6f 6e 66 69 67 66 .(import configf
0550: 6d 6f 64 29 0a 0a 28 75 73 65 20 64 75 63 74 74 mod)..(use ductt
0560: 61 70 65 2d 6c 69 62 29 0a 0a 28 69 6e 63 6c 75 ape-lib)..(inclu
0570: 64 65 20 22 6d 65 67 61 74 65 73 74 2d 66 6f 73 de "megatest-fos
0580: 73 69 6c 2d 68 61 73 68 2e 73 63 6d 22 29 0a 0a sil-hash.scm")..
0590: 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 (require-library
05a0: 20 73 74 6d 6c 29 0a 0a 3b 3b 20 73 74 75 66 66 stml)..;; stuff
05b0: 20 66 6f 72 20 74 68 65 20 6d 61 70 70 65 72 20 for the mapper
05c0: 61 6e 64 20 63 68 65 63 6b 65 72 20 66 75 6e 63 and checker func
05d0: 74 69 6f 6e 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 tions.;;.(define
05e0: 20 2a 74 61 72 67 65 74 2d 6d 61 70 70 65 72 73 *target-mappers
05f0: 2a 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 * (make-hash-ta
0600: 62 6c 65 29 29 20 0a 28 64 65 66 69 6e 65 20 2a ble)) .(define *
0610: 72 75 6e 6e 61 6d 65 2d 6d 61 70 70 65 72 73 2a runname-mappers*
0620: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0630: 65 29 29 20 0a 28 64 65 66 69 6e 65 20 2a 61 72 e)) .(define *ar
0640: 65 61 2d 63 68 65 63 6b 65 72 73 2a 20 20 20 28 ea-checkers* (
0650: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0660: 29 20 0a 0a 28 64 65 66 69 6e 65 20 28 6d 74 75 ) ..(define (mtu
0670: 74 3a 73 74 6d 6c 2d 3e 73 74 72 69 6e 67 20 69 t:stml->string i
0680: 6e 2d 73 74 6d 6c 29 0a 20 20 28 77 69 74 68 2d n-stml). (with-
0690: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
06a0: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
06b0: 20 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d (s:output-
06c0: 6e 65 77 0a 20 20 20 20 20 20 20 28 63 75 72 72 new. (curr
06d0: 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 ent-output-port)
06e0: 0a 20 20 20 20 20 20 20 69 6e 2d 73 74 6d 6c 29 . in-stml)
06f0: 29 29 29 0a 0a 3b 3b 20 68 65 6c 70 65 72 73 20 )))..;; helpers
0700: 66 6f 72 20 6d 61 70 70 65 72 73 2f 63 68 65 63 for mappers/chec
0710: 6b 65 72 73 0a 28 64 65 66 69 6e 65 20 28 61 64 kers.(define (ad
0720: 64 2d 74 61 72 67 65 74 2d 6d 61 70 70 65 72 20 d-target-mapper
0730: 6e 61 6d 65 20 70 72 6f 63 29 0a 20 20 28 68 61 name proc). (ha
0740: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 sh-table-set! *t
0750: 61 72 67 65 74 2d 6d 61 70 70 65 72 73 2a 20 6e arget-mappers* n
0760: 61 6d 65 20 70 72 6f 63 29 29 0a 28 64 65 66 69 ame proc)).(defi
0770: 6e 65 20 28 61 64 64 2d 72 75 6e 6e 61 6d 65 2d ne (add-runname-
0780: 6d 61 70 70 65 72 20 6e 61 6d 65 20 70 72 6f 63 mapper name proc
0790: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
07a0: 73 65 74 21 20 2a 72 75 6e 6e 61 6d 65 2d 6d 61 set! *runname-ma
07b0: 70 70 65 72 73 2a 20 6e 61 6d 65 20 70 72 6f 63 ppers* name proc
07c0: 29 29 0a 28 64 65 66 69 6e 65 20 28 61 64 64 2d )).(define (add-
07d0: 61 72 65 61 2d 63 68 65 63 6b 65 72 20 6e 61 6d area-checker nam
07e0: 65 20 70 72 6f 63 29 0a 20 20 28 68 61 73 68 2d e proc). (hash-
07f0: 74 61 62 6c 65 2d 73 65 74 21 20 2a 61 72 65 61 table-set! *area
0800: 2d 63 68 65 63 6b 65 72 73 2a 20 6e 61 6d 65 20 -checkers* name
0810: 70 72 6f 63 29 29 0a 0a 3b 3b 20 67 69 76 65 6e proc))..;; given
0820: 20 61 20 72 75 6e 6b 65 79 2c 20 78 6c 61 74 72 a runkey, xlatr
0830: 2d 6b 65 79 20 61 6e 64 20 6f 74 68 65 72 20 69 -key and other i
0840: 6e 66 6f 20 72 65 74 75 72 6e 20 6f 6e 65 20 6f nfo return one o
0850: 66 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 3a f the following:
0860: 0a 3b 3b 20 20 20 6c 69 73 74 20 6f 66 20 74 61 .;; list of ta
0870: 72 67 65 74 73 2c 20 6e 75 6c 6c 20 6c 69 73 74 rgets, null list
0880: 20 74 6f 20 73 6b 69 70 20 70 72 6f 63 65 73 73 to skip process
0890: 69 6e 67 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e ing.;; .(defin
08a0: 65 20 28 6d 61 70 2d 74 61 72 67 65 74 73 20 6d e (map-targets m
08b0: 74 63 6f 6e 66 20 61 76 61 6c 2d 61 6c 69 73 74 tconf aval-alist
08c0: 20 72 75 6e 6b 65 79 20 61 72 65 61 20 63 6f 6e runkey area con
08d0: 74 6f 75 72 20 23 21 6b 65 79 20 28 78 6c 61 74 tour #!key (xlat
08e0: 72 2d 6b 65 79 2d 69 6e 20 23 66 29 29 0a 20 20 r-key-in #f)).
08f0: 28 70 70 20 61 76 61 6c 2d 61 6c 69 73 74 29 0a (pp aval-alist).
0900: 20 20 28 70 72 69 6e 74 20 22 49 6e 20 4d 61 70 (print "In Map
0910: 2d 74 61 72 67 65 74 73 22 29 0a 20 20 28 6c 65 -targets"). (le
0920: 74 2a 20 28 28 78 6c 61 74 72 2d 6b 65 79 20 28 t* ((xlatr-key (
0930: 6f 72 20 78 6c 61 74 72 2d 6b 65 79 2d 69 6e 0a or xlatr-key-in.
0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0950: 20 20 20 20 20 20 20 20 28 63 6f 6e 66 2d 67 65 (conf-ge
0960: 74 2f 64 65 66 61 75 6c 74 20 6d 74 63 6f 6e 66 t/default mtconf
0970: 20 61 76 61 6c 2d 61 6c 69 73 74 20 27 74 61 72 aval-alist 'tar
0980: 67 74 72 61 6e 73 29 29 29 0a 20 20 20 20 20 20 gtrans))).
0990: 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 28 68 (proc (h
09a0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
09b0: 66 61 75 6c 74 20 2a 74 61 72 67 65 74 2d 6d 61 fault *target-ma
09c0: 70 70 65 72 73 2a 20 78 6c 61 74 72 2d 6b 65 79 ppers* xlatr-key
09d0: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 70 #f))). (if p
09e0: 72 6f 63 0a 20 20 20 20 20 20 20 20 28 62 65 67 roc. (beg
09f0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 28 70 72 in. (pr
0a00: 69 6e 74 20 22 55 73 69 6e 67 20 74 61 72 67 65 int "Using targe
0a10: 74 20 6d 61 70 70 65 72 3a 20 22 20 78 6c 61 74 t mapper: " xlat
0a20: 72 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 r-key).
0a30: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
0a40: 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 65 ons. e
0a50: 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 28 62 xn. (b
0a60: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
0a70: 20 20 28 70 72 69 6e 74 20 22 46 41 49 4c 45 44 (print "FAILED
0a80: 20 54 4f 20 52 55 4e 20 54 41 52 47 45 54 20 4d TO RUN TARGET M
0a90: 41 50 50 45 52 20 46 4f 52 20 22 20 61 72 65 61 APPER FOR " area
0aa0: 20 22 2c 20 63 61 6c 6c 65 64 20 22 20 78 6c 61 ", called " xla
0ab0: 74 72 2d 6b 65 79 29 0a 20 20 20 20 20 20 20 20 tr-key).
0ac0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 20 20 20 (print "
0ad0: 66 75 6e 63 74 69 6f 6e 20 69 73 3a 20 22 20 28 function is: " (
0ae0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0af0: 65 66 61 75 6c 74 20 2a 74 61 72 67 65 74 2d 6d efault *target-m
0b00: 61 70 70 65 72 73 2a 20 78 6c 61 74 72 2d 6b 65 appers* xlatr-ke
0b10: 79 20 23 66 20 29 20 29 0a 20 20 20 20 20 20 20 y #f ) ).
0b20: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 20 6d (print " m
0b30: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
0b40: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
0b50: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
0b60: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 ssage) exn)).
0b70: 20 20 20 20 20 20 20 20 20 20 72 75 6e 6b 65 79 runkey
0b80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 72 ). (pr
0b90: 6f 63 20 72 75 6e 6b 65 79 20 61 72 65 61 20 63 oc runkey area c
0ba0: 6f 6e 74 6f 75 72 29 29 29 0a 20 20 20 20 20 20 ontour))).
0bb0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
0bc0: 20 20 20 28 69 66 20 78 6c 61 74 72 2d 6b 65 79 (if xlatr-key
0bd0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0be0: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 (print "ERROR: F
0bf0: 61 69 6c 65 64 20 74 6f 20 66 69 6e 64 20 6e 61 ailed to find na
0c00: 6d 65 64 20 74 61 72 67 65 74 20 74 72 61 6e 73 med target trans
0c10: 6c 61 74 6f 72 20 22 20 78 6c 61 74 72 2d 6b 65 lator " xlatr-ke
0c20: 79 20 22 2c 20 75 73 69 6e 67 20 6f 72 69 67 69 y ", using origi
0c30: 6e 61 6c 20 74 61 72 67 65 74 2e 22 29 29 0a 20 nal target.")).
0c40: 20 20 20 20 20 20 20 20 20 60 28 2c 72 75 6e 6b `(,runk
0c50: 65 79 29 29 29 29 29 20 3b 3b 20 6e 6f 20 70 72 ey))))) ;; no pr
0c60: 6f 63 20 74 68 65 6e 20 75 73 65 20 72 75 6e 6b oc then use runk
0c70: 65 79 0a 0a 3b 3b 20 67 69 76 65 6e 20 6d 74 63 ey..;; given mtc
0c80: 6f 6e 66 20 61 6e 64 20 61 72 65 61 63 6f 6e 66 onf and areaconf
0c90: 20 65 78 74 72 61 63 74 20 61 20 74 72 61 6e 73 extract a trans
0ca0: 6c 61 74 6f 72 2f 66 69 6c 74 65 72 2c 20 66 69 lator/filter, fi
0cb0: 72 73 74 20 6c 6f 6f 6b 20 61 74 20 61 72 65 61 rst look at area
0cc0: 63 6f 6e 66 0a 3b 3b 20 74 68 65 6e 20 69 66 20 conf.;; then if
0cd0: 6e 6f 74 20 66 6f 75 6e 64 20 6c 6f 6f 6b 20 61 not found look a
0ce0: 74 20 64 65 66 61 75 6c 74 0a 3b 3b 0a 28 64 65 t default.;;.(de
0cf0: 66 69 6e 65 20 28 63 6f 6e 66 2d 67 65 74 2f 64 fine (conf-get/d
0d00: 65 66 61 75 6c 74 20 6d 74 63 6f 6e 66 20 61 72 efault mtconf ar
0d10: 65 61 63 6f 6e 66 20 6b 65 79 6e 61 6d 65 20 23 eaconf keyname #
0d20: 21 6b 65 79 20 28 64 65 66 61 75 6c 74 20 23 66 !key (default #f
0d30: 29 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 )). (let ((res
0d40: 28 6f 72 20 28 61 6c 69 73 74 2d 72 65 66 20 6b (or (alist-ref k
0d50: 65 79 6e 61 6d 65 20 61 72 65 61 63 6f 6e 66 29 eyname areaconf)
0d60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0d70: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
0d80: 70 20 6d 74 63 6f 6e 66 20 22 64 65 66 61 75 6c p mtconf "defaul
0d90: 74 22 20 28 63 6f 6e 63 20 6b 65 79 6e 61 6d 65 t" (conc keyname
0da0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0db0: 20 20 20 20 64 65 66 61 75 6c 74 29 29 29 0a 20 default))).
0dc0: 20 20 20 28 69 66 20 72 65 73 0a 20 20 20 20 20 (if res.
0dd0: 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 (string->symb
0de0: 6f 6c 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 ol res).
0df0: 72 65 73 29 29 29 0a 20 20 0a 3b 3b 20 74 68 69 res))). .;; thi
0e00: 73 20 6e 65 65 64 73 20 73 6f 6d 65 20 74 68 6f s needs some tho
0e10: 75 67 68 74 20 72 65 67 61 72 64 69 6e 67 20 73 ught regarding s
0e20: 65 63 75 72 69 74 79 20 69 6d 70 6c 69 63 61 74 ecurity implicat
0e30: 69 6f 6e 73 2e 0a 3b 3b 0a 3b 3b 20 20 20 69 2e ions..;;.;; i.
0e40: 20 43 68 65 63 6b 20 74 68 61 74 20 6f 77 6e 65 Check that owne
0e50: 72 20 6f 66 20 74 68 65 20 66 69 6c 65 20 61 6e r of the file an
0e60: 64 20 63 61 6c 6c 69 6e 67 20 75 73 65 72 20 61 d calling user a
0e70: 72 65 20 73 61 6d 65 3f 0a 3b 3b 20 20 69 69 2e re same?.;; ii.
0e80: 20 43 68 65 63 6b 20 74 68 61 74 20 77 65 20 61 Check that we a
0e90: 72 65 20 69 6e 20 61 20 6c 65 67 61 6c 20 6d 65 re in a legal me
0ea0: 67 61 74 65 73 74 20 61 72 65 61 3f 0a 3b 3b 20 gatest area?.;;
0eb0: 69 69 69 2e 20 48 61 76 65 20 73 6f 6d 65 20 66 iii. Have some f
0ec0: 6f 72 6d 20 6f 66 20 61 75 74 68 65 6e 74 69 63 orm of authentic
0ed0: 61 74 69 6f 6e 20 6f 72 20 72 65 63 6f 72 64 20 ation or record
0ee0: 6f 66 20 74 68 65 20 6d 64 35 73 75 6d 20 6f 72 of the md5sum or
0ef0: 20 73 69 6d 69 6c 61 72 20 6f 66 20 74 68 65 20 similar of the
0f00: 66 69 6c 65 3f 0a 3b 3b 20 20 69 76 2e 20 55 73 file?.;; iv. Us
0f10: 65 20 63 6f 6d 70 69 6c 65 64 20 76 65 72 73 69 e compiled versi
0f20: 6f 6e 20 69 6e 20 70 72 65 66 65 72 65 6e 63 65 on in preference
0f30: 20 74 6f 20 2e 73 63 6d 20 76 65 72 73 69 6f 6e to .scm version
0f40: 2e 20 54 68 75 73 20 74 68 65 72 65 20 69 73 20 . Thus there is
0f50: 61 20 6d 61 6e 75 61 6c 20 22 62 6c 65 73 73 69 a manual "blessi
0f60: 6e 67 22 0a 3b 3b 20 20 20 20 20 20 72 65 71 75 ng".;; requ
0f70: 69 72 65 64 20 74 6f 20 75 73 65 20 2e 6d 74 75 ired to use .mtu
0f80: 74 69 6c 2e 73 63 6d 2e 0a 3b 3b 0a 28 69 66 20 til.scm..;;.(if
0f90: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
0fa0: 73 74 73 3f 20 22 6d 65 67 61 74 65 73 74 2e 63 sts? "megatest.c
0fb0: 6f 6e 66 69 67 22 29 0a 20 20 20 20 28 69 66 20 onfig"). (if
0fc0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
0fd0: 73 74 73 3f 20 22 2e 6d 74 75 74 69 6c 2e 73 6f sts? ".mtutil.so
0fe0: 22 29 0a 09 28 6c 6f 61 64 20 22 2e 6d 74 75 74 ")..(load ".mtut
0ff0: 69 6c 2e 73 6f 22 29 0a 09 28 69 66 20 28 63 6f il.so")..(if (co
1000: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
1010: 3f 20 22 2e 6d 74 75 74 69 6c 2e 73 63 6d 22 29 ? ".mtutil.scm")
1020: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f . (lo
1030: 61 64 20 22 2e 6d 74 75 74 69 6c 2e 73 63 6d 22 ad ".mtutil.scm"
1040: 29 29 29 29 0a 0a 3b 3b 20 6d 61 69 6e 20 74 68 ))))..;; main th
1050: 72 65 65 20 74 79 70 65 73 20 6f 66 20 72 75 6e ree types of run
1060: 0a 3b 3b 20 20 22 2d 72 75 6e 22 20 20 20 20 20 .;; "-run"
1070: 20 20 20 20 3d 3e 20 69 6e 69 74 69 61 74 65 20 => initiate
1080: 61 20 72 75 6e 0a 3b 3b 20 20 22 2d 72 65 72 75 a run.;; "-reru
1090: 6e 2d 63 6c 65 61 6e 22 20 3d 3e 20 73 65 74 20 n-clean" => set
10a0: 66 61 69 6c 65 64 2c 20 61 62 6f 72 74 65 64 2c failed, aborted,
10b0: 20 6b 69 6c 6c 65 64 2c 20 65 74 63 2e 20 28 6e killed, etc. (n
10c0: 6f 74 20 70 61 73 73 2f 66 61 69 6c 29 20 74 6f ot pass/fail) to
10d0: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 NOT_STARTED and
10e0: 20 6b 69 63 6b 20 6f 66 66 20 72 75 6e 0a 3b 3b kick off run.;;
10f0: 20 20 22 2d 72 65 72 75 6e 2d 61 6c 6c 22 20 20 "-rerun-all"
1100: 20 3d 3e 20 73 65 74 20 61 6c 6c 20 74 65 73 74 => set all test
1110: 73 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e s NOT_STARTED an
1120: 64 20 6b 69 63 6b 20 6f 66 66 20 72 75 6e 20 61 d kick off run a
1130: 67 61 69 6e 0a 0a 3b 3b 20 64 65 70 72 65 63 61 gain..;; depreca
1140: 74 65 64 2f 64 6f 20 6e 6f 74 20 75 73 65 0a 3b ted/do not use.;
1150: 3b 20 20 22 2d 72 75 6e 61 6c 6c 22 20 20 20 20 ; "-runall"
1160: 20 20 3d 3e 20 73 79 6e 6f 6e 79 6d 20 66 6f 72 => synonym for
1170: 20 72 75 6e 2c 20 64 6f 20 6e 6f 74 20 75 73 65 run, do not use
1180: 0a 3b 3b 20 20 22 2d 72 75 6e 74 65 73 74 73 22 .;; "-runtests"
1190: 20 20 20 20 3d 3e 20 73 79 6e 6f 6e 79 6d 20 66 => synonym f
11a0: 6f 72 20 72 75 6e 2c 20 64 6f 20 6e 6f 74 20 75 or run, do not u
11b0: 73 65 0a 0a 3b 3b 20 44 69 73 61 62 6c 65 64 20 se..;; Disabled
11c0: 68 65 6c 70 20 69 74 65 6d 73 0a 3b 3b 20 20 2d help items.;; -
11d0: 72 6f 6c 6c 75 70 20 20 20 20 20 20 20 20 20 20 rollup
11e0: 20 20 20 20 20 20 20 3a 20 28 63 75 72 72 65 6e : (curren
11f0: 74 6c 79 20 64 69 73 61 62 6c 65 64 29 20 66 69 tly disabled) fi
1200: 6c 6c 20 72 75 6e 20 28 73 65 74 20 62 79 20 3a ll run (set by :
1210: 72 75 6e 6e 61 6d 65 29 20 20 77 69 74 68 20 6c runname) with l
1220: 61 74 65 73 74 20 74 65 73 74 28 73 29 0a 3b 3b atest test(s).;;
1230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1240: 20 20 20 20 20 20 20 20 20 20 20 20 66 72 6f 6d from
1250: 20 70 72 69 6f 72 20 72 75 6e 73 20 77 69 74 68 prior runs with
1260: 20 73 61 6d 65 20 6b 65 79 73 0a 3b 3b 20 43 6f same keys.;; Co
1270: 6e 74 6f 75 72 20 61 63 74 69 6f 6e 73 0a 3b 3b ntour actions.;;
1280: 20 20 20 20 69 6d 70 6f 72 74 20 20 20 20 20 20 import
1290: 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 69 6d : im
12a0: 70 6f 72 74 20 70 6b 74 73 0a 3b 3b 20 20 20 20 port pkts.;;
12b0: 64 69 73 70 61 74 63 68 20 20 20 20 20 20 20 20 dispatch
12c0: 20 20 20 20 20 20 20 20 3a 20 64 69 73 70 61 74 : dispat
12d0: 63 68 20 71 75 65 75 65 64 20 72 75 6e 20 6a 6f ch queued run jo
12e0: 62 73 20 66 72 6f 6d 20 69 6d 70 6f 72 74 65 64 bs from imported
12f0: 20 70 6b 74 73 0a 3b 3b 20 20 20 20 72 75 6e 67 pkts.;; rung
1300: 65 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 en
1310: 20 20 20 20 3a 20 6c 6f 6f 6b 20 61 74 20 69 6e : look at in
1320: 70 75 74 20 73 65 6e 73 65 20 6c 69 73 74 20 69 put sense list i
1330: 6e 20 5b 72 75 6e 67 65 6e 5d 20 61 6e 64 20 67 n [rungen] and g
1340: 65 6e 65 72 61 74 65 20 72 75 6e 20 70 6b 74 73 enerate run pkts
1350: 0a 0a 28 64 65 66 69 6e 65 20 68 65 6c 70 20 28 ..(define help (
1360: 63 6f 6e 63 20 22 0a 6d 74 75 74 69 6c 2c 20 70 conc ".mtutil, p
1370: 61 72 74 20 6f 66 20 74 68 65 20 4d 65 67 61 74 art of the Megat
1380: 65 73 74 20 74 6f 6f 6c 20 73 75 69 74 65 2c 20 est tool suite,
1390: 64 6f 63 75 6d 65 6e 74 61 74 69 6f 6e 20 61 74 documentation at
13a0: 20 68 74 74 70 3a 2f 2f 77 77 77 2e 6b 69 61 74 http://www.kiat
13b0: 6f 61 2e 63 6f 6d 2f 66 6f 73 73 69 6c 73 2f 6d oa.com/fossils/m
13c0: 65 67 61 74 65 73 74 0a 20 20 76 65 72 73 69 6f egatest. versio
13d0: 6e 20 22 20 6d 65 67 61 74 65 73 74 2d 76 65 72 n " megatest-ver
13e0: 73 69 6f 6e 20 22 0a 20 20 6c 69 63 65 6e 73 65 sion ". license
13f0: 20 47 50 4c 2c 20 43 6f 70 79 72 69 67 68 74 20 GPL, Copyright
1400: 4d 61 74 74 20 57 65 6c 6c 61 6e 64 20 32 30 30 Matt Welland 200
1410: 36 2d 32 30 31 37 0a 0a 55 73 61 67 65 3a 20 6d 6-2017..Usage: m
1420: 74 75 74 69 6c 20 61 63 74 69 6f 6e 20 5b 6f 70 tutil action [op
1430: 74 69 6f 6e 73 5d 0a 20 20 2d 68 20 20 20 20 20 tions]. -h
1440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1450: 20 20 20 20 3a 20 74 68 69 73 20 68 65 6c 70 0a : this help.
1460: 20 20 2d 6d 61 6e 75 61 6c 20 20 20 20 20 20 20 -manual
1470: 20 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 73 : s
1480: 68 6f 77 20 74 68 65 20 4d 65 67 61 74 65 73 74 how the Megatest
1490: 20 75 73 65 72 20 6d 61 6e 75 61 6c 0a 20 20 2d user manual. -
14a0: 76 65 72 73 69 6f 6e 20 20 20 20 20 20 20 20 20 version
14b0: 20 20 20 20 20 20 20 20 20 20 3a 20 70 72 69 6e : prin
14c0: 74 20 6d 65 67 61 74 65 73 74 20 76 65 72 73 69 t megatest versi
14d0: 6f 6e 20 28 63 75 72 72 65 6e 74 6c 79 20 22 20 on (currently "
14e0: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
14f0: 20 22 29 0a 09 09 09 20 20 20 20 20 0a 52 75 6e ").... .Run
1500: 20 6d 61 6e 61 67 65 6d 65 6e 74 3a 09 09 20 20 management:..
1510: 20 20 20 0a 20 20 20 72 75 6e 20 20 20 20 20 20 . run
1520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1530: 20 3a 20 69 6e 69 74 69 61 74 65 20 6f 72 20 72 : initiate or r
1540: 65 73 75 6d 65 20 61 20 72 75 6e 2c 20 61 6c 72 esume a run, alr
1550: 65 61 64 79 20 63 6f 6d 70 6c 65 74 65 64 20 61 eady completed a
1560: 6e 64 20 69 6e 2d 70 72 6f 67 72 65 73 73 0a 20 nd in-progress.
1570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 te
1590: 73 74 73 20 61 72 65 20 6e 6f 74 20 61 66 66 65 sts are not affe
15a0: 63 74 65 64 2e 0a 20 20 20 72 65 72 75 6e 2d 63 cted.. rerun-c
15b0: 6c 65 61 6e 20 20 20 20 20 20 20 20 20 20 20 20 lean
15c0: 20 20 20 3a 20 63 6c 65 61 6e 20 61 6e 64 20 72 : clean and r
15d0: 65 72 75 6e 20 61 6c 6c 20 6e 6f 74 20 63 6f 6d erun all not com
15e0: 70 6c 65 74 65 64 20 70 61 73 73 2f 66 61 69 6c pleted pass/fail
15f0: 20 74 65 73 74 73 0a 20 20 20 72 65 72 75 6e 2d tests. rerun-
1600: 61 6c 6c 20 20 20 20 20 20 20 20 20 20 20 20 20 all
1610: 20 20 20 20 3a 20 63 6c 65 61 6e 20 61 6e 64 20 : clean and
1620: 72 65 72 75 6e 20 65 6e 74 69 72 65 20 72 75 6e rerun entire run
1630: 0a 20 20 20 6b 69 6c 6c 2d 72 75 6e 20 20 20 20 . kill-run
1640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 :
1650: 6b 69 6c 6c 20 61 6c 6c 20 74 65 73 74 73 20 69 kill all tests i
1660: 6e 20 72 75 6e 0a 20 20 20 6b 69 6c 6c 2d 72 65 n run. kill-re
1670: 72 75 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 run
1680: 20 20 20 3a 20 6b 69 6c 6c 20 61 6c 6c 20 74 65 : kill all te
1690: 73 74 73 20 69 6e 20 72 75 6e 20 61 6e 64 20 72 sts in run and r
16a0: 65 73 74 61 72 74 20 6e 6f 6e 2d 63 6f 6d 70 6c estart non-compl
16b0: 65 74 65 64 20 74 65 73 74 73 0a 20 20 20 72 65 eted tests. re
16c0: 6d 6f 76 65 20 20 20 20 20 20 20 20 20 20 20 20 move
16d0: 20 20 20 20 20 20 20 20 3a 20 72 65 6d 6f 76 65 : remove
16e0: 20 72 75 6e 73 0a 20 20 20 73 65 74 2d 73 73 20 runs. set-ss
16f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1700: 20 20 20 3a 20 73 65 74 20 73 74 61 74 65 2f 73 : set state/s
1710: 74 61 74 75 73 0a 20 20 20 61 72 63 68 69 76 65 tatus. archive
1720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1730: 20 20 20 3a 20 63 6f 6d 70 72 65 73 73 20 61 6e : compress an
1740: 64 20 6d 6f 76 65 20 74 65 73 74 20 64 61 74 61 d move test data
1750: 20 74 6f 20 61 72 63 68 69 76 65 20 64 69 73 6b to archive disk
1760: 0a 20 20 20 6b 69 6c 6c 20 20 20 20 20 20 20 20 . kill
1770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 :
1780: 73 74 6f 70 20 74 65 73 74 73 20 6f 72 20 65 6e stop tests or en
1790: 74 69 72 65 20 72 75 6e 73 0a 20 20 20 64 62 20 tire runs. db
17a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17b0: 20 20 20 20 20 20 20 3a 20 64 61 74 61 62 61 73 : databas
17c0: 65 20 75 74 69 6c 69 74 69 65 73 0a 0a 51 75 65 e utilities..Que
17d0: 72 69 65 73 3a 0a 20 20 20 73 68 6f 77 20 5b 61 ries:. show [a
17e0: 72 65 61 73 7c 63 6f 6e 74 6f 75 72 73 2e 2e 2e reas|contours...
17f0: 20 5d 20 3a 20 73 68 6f 77 20 61 72 65 61 73 2c ] : show areas,
1800: 20 63 6f 6e 74 6f 75 72 73 20 6f 72 20 6f 74 68 contours or oth
1810: 65 72 20 73 65 63 74 69 6f 6e 20 66 72 6f 6d 20 er section from
1820: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 0a megatest.config.
1830: 20 20 20 67 65 6e 64 6f 74 20 20 20 20 20 20 20 gendot
1840: 20 20 20 20 20 20 20 20 20 20 20 20 20 3a 20 67 : g
1850: 65 6e 65 72 61 74 65 20 61 20 67 72 61 70 68 76 enerate a graphv
1860: 69 7a 20 64 6f 74 20 66 69 6c 65 20 66 72 6f 6d iz dot file from
1870: 20 70 6b 74 73 2e 0a 0a 43 6f 6e 74 6f 75 72 20 pkts...Contour
1880: 61 63 74 69 6f 6e 73 3a 0a 20 20 20 70 72 6f 63 actions:. proc
1890: 65 73 73 20 20 20 20 20 20 20 20 20 20 20 20 20 ess
18a0: 20 20 20 20 20 20 3a 20 72 75 6e 73 20 69 6d 70 : runs imp
18b0: 6f 72 74 2c 20 72 75 6e 67 65 6e 20 61 6e 64 20 ort, rungen and
18c0: 64 69 73 70 61 74 63 68 20 0a 09 09 09 20 20 20 dispatch ....
18d0: 20 20 0a 54 72 69 67 67 65 72 20 70 72 6f 70 61 .Trigger propa
18e0: 67 61 74 69 6f 6e 20 61 63 74 69 6f 6e 73 3a 0a gation actions:.
18f0: 20 20 20 74 73 65 6e 64 20 61 3d 62 2c 63 3d 64 tsend a=b,c=d
1900: 2e 2e 2e 20 20 20 20 20 20 20 20 20 20 3a 20 73 ... : s
1910: 65 6e 64 20 74 72 69 67 67 65 72 20 69 6e 66 6f end trigger info
1920: 20 74 6f 20 61 6c 6c 20 72 65 63 70 69 65 6e 74 to all recpient
1930: 73 20 69 6e 20 74 68 65 20 5b 6c 69 73 74 65 6e s in the [listen
1940: 65 72 73 5d 20 73 65 63 74 69 6f 6e 0a 20 20 20 ers] section.
1950: 74 6c 69 73 74 65 6e 20 2d 70 6f 72 74 20 4e 20 tlisten -port N
1960: 20 20 20 20 20 20 20 20 20 20 3a 20 6c 69 73 74 : list
1970: 65 6e 20 66 6f 72 20 74 72 69 67 67 65 72 20 69 en for trigger i
1980: 6e 66 6f 20 6f 6e 20 70 6f 72 74 20 4e 0a 09 09 nfo on port N...
1990: 09 20 20 20 20 20 0a 53 65 6c 65 63 74 6f 72 73 . .Selectors
19a0: 20 09 09 20 20 20 20 20 0a 20 20 2d 69 6d 6d 65 .. . -imme
19b0: 64 69 61 74 65 20 20 20 20 20 20 20 20 20 20 20 diate
19c0: 20 20 20 20 20 20 3a 20 61 70 70 6c 79 20 74 68 : apply th
19d0: 69 73 20 61 63 74 69 6f 6e 20 69 6d 6d 65 64 69 is action immedi
19e0: 61 74 65 6c 79 2c 20 64 65 66 61 75 6c 74 20 69 ately, default i
19f0: 73 20 74 6f 20 71 75 65 75 65 20 75 70 20 61 63 s to queue up ac
1a00: 74 69 6f 6e 73 0a 20 20 2d 61 72 65 61 20 61 72 tions. -area ar
1a10: 65 61 70 61 74 74 31 2c 61 72 65 61 32 2e 2e 2e eapatt1,area2...
1a20: 20 20 20 3a 20 61 70 70 6c 79 20 74 68 69 73 20 : apply this
1a30: 61 63 74 69 6f 6e 20 6f 6e 6c 79 20 74 6f 20 74 action only to t
1a40: 68 65 20 73 70 65 63 69 66 69 65 64 20 61 72 65 he specified are
1a50: 61 73 0a 20 20 2d 74 61 72 67 65 74 20 6b 65 79 as. -target key
1a60: 31 2f 6b 65 79 32 2f 2e 2e 2e 20 20 20 20 20 20 1/key2/...
1a70: 3a 20 72 75 6e 20 66 6f 72 20 6b 65 79 31 2c 20 : run for key1,
1a80: 6b 65 79 32 2c 20 65 74 63 2e 0a 20 20 2d 74 65 key2, etc.. -te
1a90: 73 74 2d 70 61 74 74 20 70 31 2f 70 32 2c 70 33 st-patt p1/p2,p3
1aa0: 2f 2e 2e 2e 20 20 20 20 3a 20 25 20 69 73 20 77 /... : % is w
1ab0: 69 6c 64 63 61 72 64 0a 20 20 2d 72 75 6e 2d 6e ildcard. -run-n
1ac0: 61 6d 65 20 20 20 20 20 20 20 20 20 20 20 20 20 ame
1ad0: 20 20 20 20 20 3a 20 72 65 71 75 69 72 65 64 2c : required,
1ae0: 20 6e 61 6d 65 20 66 6f 72 20 74 68 69 73 20 70 name for this p
1af0: 61 72 74 69 63 75 6c 61 72 20 74 65 73 74 20 72 articular test r
1b00: 75 6e 0a 20 20 2d 63 6f 6e 74 6f 75 72 20 63 6f un. -contour co
1b10: 6e 74 6f 75 72 6e 61 6d 65 20 20 20 20 20 20 20 ntourname
1b20: 3a 20 72 75 6e 20 61 6c 6c 20 74 61 72 67 65 74 : run all target
1b30: 73 20 66 6f 72 20 63 6f 6e 74 6f 75 72 6e 61 6d s for contournam
1b40: 65 2c 20 72 65 71 75 69 72 65 73 20 2d 72 75 6e e, requires -run
1b50: 2d 6e 61 6d 65 2c 20 2d 74 61 72 67 65 74 0a 20 -name, -target.
1b60: 20 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 63 -state-status c
1b70: 2f 70 2c 63 2f 66 20 20 20 20 20 20 3a 20 53 70 /p,c/f : Sp
1b80: 65 63 69 66 79 20 61 20 6c 69 73 74 20 6f 66 20 ecify a list of
1b90: 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 state and status
1ba0: 20 70 61 74 74 65 72 6e 73 0a 20 20 2d 74 61 67 patterns. -tag
1bb0: 2d 65 78 70 72 20 74 61 67 31 2c 74 61 67 32 25 -expr tag1,tag2%
1bc0: 2c 2e 2e 20 20 20 20 3a 20 73 65 6c 65 63 74 20 ,.. : select
1bd0: 74 65 73 74 73 20 77 69 74 68 20 74 61 67 73 20 tests with tags
1be0: 6d 61 74 63 68 69 6e 67 20 65 78 70 72 65 73 73 matching express
1bf0: 69 6f 6e 0a 20 20 2d 6d 6f 64 65 2d 70 61 74 74 ion. -mode-patt
1c00: 20 6b 65 79 20 20 20 20 20 20 20 20 20 20 20 20 key
1c10: 20 3a 20 6c 6f 61 64 20 74 65 73 74 70 61 74 74 : load testpatt
1c20: 20 66 72 6f 6d 20 3c 6b 65 79 3e 20 69 6e 20 72 from <key> in r
1c30: 75 6e 63 6f 6e 66 69 67 73 20 69 6e 73 74 65 61 unconfigs instea
1c40: 64 20 6f 66 20 64 65 66 61 75 6c 74 20 54 45 53 d of default TES
1c50: 54 50 41 54 54 0a 20 20 20 20 20 20 20 20 20 20 TPATT.
1c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c70: 20 20 20 20 20 69 66 20 2d 74 65 73 74 70 61 74 if -testpat
1c80: 74 20 61 6e 64 20 2d 74 61 67 65 78 70 72 20 61 t and -tagexpr a
1c90: 72 65 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 re not specified
1ca0: 0a 20 20 2d 6e 65 77 20 73 74 61 74 65 2f 73 74 . -new state/st
1cb0: 61 74 75 73 20 20 20 20 20 20 20 20 20 20 3a 20 atus :
1cc0: 73 70 65 63 69 66 79 20 6e 65 77 20 73 74 61 74 specify new stat
1cd0: 65 2f 73 74 61 74 75 73 20 66 6f 72 20 73 65 74 e/status for set
1ce0: 2d 73 73 0a 09 09 09 20 20 20 20 20 0a 4d 69 73 -ss.... .Mis
1cf0: 63 20 09 09 09 20 20 20 20 20 0a 20 20 2d 73 74 c ... . -st
1d00: 61 72 74 2d 64 69 72 20 70 61 74 68 20 20 20 20 art-dir path
1d10: 20 20 20 20 20 20 20 20 3a 20 73 77 69 74 63 68 : switch
1d20: 20 74 6f 20 74 68 69 73 20 64 69 72 65 63 74 6f to this directo
1d30: 72 79 20 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e ry before runnin
1d40: 67 20 6d 74 75 74 69 6c 0a 20 20 2d 73 65 74 2d g mtutil. -set-
1d50: 76 61 72 73 20 56 31 3d 31 2c 56 32 3d 32 20 20 vars V1=1,V2=2
1d60: 20 20 20 20 20 20 3a 20 41 64 64 20 65 6e 76 69 : Add envi
1d70: 72 6f 6e 6d 65 6e 74 20 76 61 72 69 61 62 6c 65 ronment variable
1d80: 73 20 74 6f 20 61 20 72 75 6e 20 4e 42 2f 2f 20 s to a run NB//
1d90: 74 68 65 73 65 20 61 72 65 0a 20 20 20 20 20 20 these are.
1da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 76 65 ove
1dc0: 72 77 72 69 74 74 65 6e 20 62 79 20 76 61 6c 75 rwritten by valu
1dd0: 65 73 20 73 65 74 20 69 6e 20 63 6f 6e 66 69 67 es set in config
1de0: 20 66 69 6c 65 73 2e 0a 20 20 2d 6c 6f 67 20 6c files.. -log l
1df0: 6f 67 66 69 6c 65 20 20 20 20 20 20 20 20 20 20 ogfile
1e00: 20 20 20 20 20 3a 20 73 65 6e 64 20 73 74 64 6f : send stdo
1e10: 75 74 20 61 6e 64 20 73 74 64 65 72 72 20 74 6f ut and stderr to
1e20: 20 6c 6f 67 66 69 6c 65 0a 20 20 2d 72 65 70 6c logfile. -repl
1e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e40: 20 20 20 20 20 20 3a 20 73 74 61 72 74 20 61 20 : start a
1e50: 72 65 70 6c 20 28 75 73 65 66 75 6c 20 66 6f 72 repl (useful for
1e60: 20 65 78 74 65 6e 64 69 6e 67 20 6d 65 67 61 74 extending megat
1e70: 65 73 74 29 0a 20 20 2d 6c 6f 61 64 20 66 69 6c est). -load fil
1e80: 65 2e 73 63 6d 20 20 20 20 20 20 20 20 20 20 20 e.scm
1e90: 20 20 3a 20 6c 6f 61 64 20 61 6e 64 20 72 75 6e : load and run
1ea0: 20 66 69 6c 65 2e 73 63 6d 0a 20 20 2d 64 65 62 file.scm. -deb
1eb0: 75 67 20 4e 7c 4e 2c 4d 2c 4f 2e 2e 2e 20 20 20 ug N|N,M,O...
1ec0: 20 20 20 20 20 20 20 3a 20 65 6e 61 62 6c 65 20 : enable
1ed0: 64 65 62 75 67 20 6d 65 73 73 61 67 65 73 20 30 debug messages 0
1ee0: 2d 4e 20 6f 72 20 4e 20 61 6e 64 20 4d 20 61 6e -N or N and M an
1ef0: 64 20 4f 20 2e 2e 2e 0a 20 20 2d 6c 69 73 74 2d d O .... -list-
1f00: 70 6b 74 2d 6b 65 79 73 20 20 20 20 20 20 20 20 pkt-keys
1f10: 20 20 20 20 20 3a 20 6c 69 73 74 20 61 6c 6c 20 : list all
1f20: 70 6b 74 20 6b 65 79 73 0a 09 09 09 20 20 20 20 pkt keys....
1f30: 20 0a 55 74 69 6c 69 74 79 09 09 09 20 20 20 20 .Utility...
1f40: 20 0a 20 64 62 20 70 67 73 63 68 65 6d 61 20 20 . db pgschema
1f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a :
1f60: 20 65 6d 69 74 20 70 6f 73 74 67 72 65 73 71 6c emit postgresql
1f70: 20 73 63 68 65 6d 61 3b 20 64 6f 20 5c 22 6d 74 schema; do \"mt
1f80: 75 74 69 6c 20 64 62 20 70 67 73 63 68 65 6d 61 util db pgschema
1f90: 20 7c 20 70 73 71 6c 20 2d 64 20 6d 79 64 62 5c | psql -d mydb\
1fa0: 22 0a 20 67 61 74 68 65 72 64 62 20 5b 70 72 6f ". gatherdb [pro
1fb0: 70 61 67 61 74 65 5d 20 20 20 20 20 20 20 20 3a pagate] :
1fc0: 20 67 61 74 68 65 72 20 64 62 73 20 66 72 6f 6d gather dbs from
1fd0: 20 61 6c 6c 20 61 72 65 61 73 20 69 6e 74 6f 20 all areas into
1fe0: 2f 74 6d 70 2f 24 55 53 45 52 5f 6d 65 67 61 74 /tmp/$USER_megat
1ff0: 65 73 74 2f 61 6c 6c 64 62 73 2c 0a 20 20 20 20 est/alldbs,.
2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2010: 20 20 20 20 20 20 20 20 20 20 20 6f 70 74 69 6f optio
2020: 6e 61 6c 6c 79 20 70 72 6f 70 61 67 61 74 65 20 nally propagate
2030: 74 68 65 20 64 61 74 61 20 74 6f 20 6d 65 67 61 the data to mega
2040: 74 65 73 74 32 2e 30 20 66 6f 72 6d 61 74 0a 20 test2.0 format.
2050: 0a 0a 45 78 61 6d 70 6c 65 73 3a 0a 0a 23 20 53 ..Examples:..# S
2060: 74 61 72 74 20 61 20 6d 65 67 61 74 65 73 74 20 tart a megatest
2070: 72 75 6e 20 69 6e 20 74 68 65 20 61 72 65 61 20 run in the area
2080: 5c 22 6d 79 74 65 73 74 73 5c 22 0a 6d 74 75 74 \"mytests\".mtut
2090: 69 6c 20 72 75 6e 20 2d 61 72 65 61 20 6d 79 74 il run -area myt
20a0: 65 73 74 73 20 2d 74 61 72 67 65 74 20 76 31 2e ests -target v1.
20b0: 36 33 2f 61 61 33 65 20 2d 6d 6f 64 65 2d 70 61 63/aa3e -mode-pa
20c0: 74 74 20 4d 59 50 41 54 54 20 2d 74 61 67 2d 65 tt MYPATT -tag-e
20d0: 78 70 72 20 71 75 69 63 6b 0a 0a 23 20 53 74 61 xpr quick..# Sta
20e0: 72 74 20 61 20 63 6f 6e 74 6f 75 72 0a 6d 74 75 rt a contour.mtu
20f0: 74 69 6c 20 72 75 6e 20 2d 63 6f 6e 74 6f 75 72 til run -contour
2100: 20 71 75 69 63 6b 20 2d 74 61 72 67 65 74 20 76 quick -target v
2110: 31 2e 36 33 2f 61 61 33 65 20 0a 0a 43 61 6c 6c 1.63/aa3e ..Call
2120: 65 64 20 61 73 20 22 20 28 73 74 72 69 6e 67 2d ed as " (string-
2130: 69 6e 74 65 72 73 70 65 72 73 65 20 28 61 72 67 intersperse (arg
2140: 76 29 20 22 20 22 29 20 22 0a 56 65 72 73 69 6f v) " ") ".Versio
2150: 6e 20 22 20 6d 65 67 61 74 65 73 74 2d 76 65 72 n " megatest-ver
2160: 73 69 6f 6e 20 22 2c 20 62 75 69 6c 74 20 66 72 sion ", built fr
2170: 6f 6d 20 22 20 6d 65 67 61 74 65 73 74 2d 66 6f om " megatest-fo
2180: 73 73 69 6c 2d 68 61 73 68 20 29 29 0a 0a 3b 3b ssil-hash ))..;;
2190: 20 61 72 67 73 20 61 6e 64 20 70 6b 74 20 6b 65 args and pkt ke
21a0: 79 20 73 70 65 63 73 0a 3b 3b 0a 28 64 65 66 69 y specs.;;.(defi
21b0: 6e 65 20 2a 61 72 67 2d 6b 65 79 73 2a 0a 20 20 ne *arg-keys*.
21c0: 3b 3b 20 75 73 65 64 20 6b 65 79 73 0a 20 20 3b ;; used keys. ;
21d0: 3b 20 20 20 20 61 20 20 2d 20 61 63 74 69 6f 6e ; a - action
21e0: 0a 20 20 27 28 0a 20 20 20 20 28 22 2d 61 72 65 . '(. ("-are
21f0: 61 22 20 20 20 20 20 20 20 20 20 20 20 20 2e 20 a" .
2200: 47 29 20 3b 3b 20 6d 61 70 73 20 74 6f 20 67 72 G) ;; maps to gr
2210: 6f 75 70 0a 20 20 20 20 28 22 2d 63 6f 6e 74 6f oup. ("-conto
2220: 75 72 22 20 20 20 20 20 20 20 20 20 2e 20 63 29 ur" . c)
2230: 0a 20 20 20 20 28 22 2d 61 70 70 65 6e 64 2d 63 . ("-append-c
2240: 6f 6e 66 69 67 22 20 20 20 2e 20 64 29 0a 20 20 onfig" . d).
2250: 20 20 28 22 2d 73 74 61 74 65 22 20 20 20 20 20 ("-state"
2260: 20 20 20 20 20 20 2e 20 65 29 0a 20 20 20 20 28 . e). (
2270: 22 2d 69 74 65 6d 2d 70 61 74 74 22 20 20 20 20 "-item-patt"
2280: 20 20 20 2e 20 69 29 0a 20 20 20 20 28 22 2d 73 . i). ("-s
2290: 79 6e 63 2d 74 6f 22 20 20 20 20 20 20 20 20 20 ync-to"
22a0: 2e 20 6b 29 0a 20 20 20 20 28 22 2d 6e 65 77 22 . k). ("-new"
22b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 2e 20 6c . l
22c0: 29 20 3b 3b 20 6c 20 28 73 65 65 20 62 65 6c 6f ) ;; l (see belo
22d0: 77 29 20 69 73 20 6e 65 77 2d 73 73 0a 20 20 20 w) is new-ss.
22e0: 20 28 22 2d 72 75 6e 2d 6e 61 6d 65 22 20 20 20 ("-run-name"
22f0: 20 20 20 20 20 2e 20 6e 29 0a 20 20 20 20 28 22 . n). ("
2300: 2d 6d 6f 64 65 2d 70 61 74 74 22 20 20 20 20 20 -mode-patt"
2310: 20 20 2e 20 6f 29 0a 20 20 20 20 28 22 2d 74 65 . o). ("-te
2320: 73 74 2d 70 61 74 74 22 20 20 20 20 20 20 20 2e st-patt" .
2330: 20 70 29 20 20 3b 3b 20 69 64 65 61 2c 20 65 6e p) ;; idea, en
2340: 68 61 6e 63 65 20 6d 61 72 67 73 20 28 22 2d 74 hance margs ("-t
2350: 65 73 74 2d 70 61 74 74 22 20 22 2d 74 65 73 74 est-patt" "-test
2360: 70 61 74 74 22 29 20 3d 3e 20 79 69 65 6c 64 73 patt") => yields
2370: 20 6f 6e 65 20 76 61 6c 75 65 20 69 6e 20 22 2d one value in "-
2380: 74 65 73 74 2d 70 61 74 74 22 0a 20 20 20 20 28 test-patt". (
2390: 22 2d 73 74 61 74 75 73 22 20 20 20 20 20 20 20 "-status"
23a0: 20 20 20 2e 20 73 29 0a 20 20 20 20 28 22 2d 74 . s). ("-t
23b0: 61 72 67 65 74 22 20 20 20 20 20 20 20 20 20 20 arget"
23c0: 2e 20 74 29 0a 20 20 20 20 28 22 2d 72 65 71 74 . t). ("-reqt
23d0: 61 72 67 22 20 20 20 20 20 20 20 20 20 2e 20 52 arg" . R
23e0: 29 0a 0a 20 20 20 20 28 22 2d 74 61 67 2d 65 78 ).. ("-tag-ex
23f0: 70 72 22 20 20 20 20 20 20 20 20 2e 20 78 29 0a pr" . x).
2400: 20 20 20 20 3b 3b 20 6d 69 73 63 0a 20 20 20 20 ;; misc.
2410: 28 22 2d 64 65 62 75 67 22 20 20 20 20 20 20 20 ("-debug"
2420: 20 20 20 20 2e 20 23 66 29 20 20 3b 3b 20 66 6f . #f) ;; fo
2430: 72 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 3e 20 r *verbosity* >
2440: 32 0a 20 20 20 20 28 22 2d 6c 6f 61 64 22 20 20 2. ("-load"
2450: 20 20 20 20 20 20 20 20 20 20 2e 20 23 66 29 20 . #f)
2460: 20 3b 3b 20 6c 6f 61 64 20 61 6e 64 20 65 78 65 ;; load and exe
2470: 63 74 75 74 65 20 61 20 73 63 68 65 6d 65 20 66 ctute a scheme f
2480: 69 6c 65 0a 20 20 20 20 28 22 2d 6c 6f 67 22 20 ile. ("-log"
2490: 20 20 20 20 20 20 20 20 20 20 20 20 2e 20 23 66 . #f
24a0: 29 0a 20 20 20 20 28 22 2d 6f 76 65 72 72 69 64 ). ("-overrid
24b0: 65 2d 75 73 65 72 22 20 20 20 2e 20 23 66 29 0a e-user" . #f).
24c0: 20 20 20 20 28 22 2d 6d 73 67 22 20 20 20 20 20 ("-msg"
24d0: 20 20 20 20 20 20 20 20 2e 20 4d 29 0a 20 20 20 . M).
24e0: 20 28 22 2d 73 74 61 72 74 2d 64 69 72 22 20 20 ("-start-dir"
24f0: 20 20 20 20 20 2e 20 53 29 0a 20 20 20 20 28 22 . S). ("
2500: 2d 73 65 74 2d 76 61 72 73 22 20 20 20 20 20 20 -set-vars"
2510: 20 20 2e 20 76 29 0a 20 20 20 20 28 22 2d 63 6f . v). ("-co
2520: 6e 66 69 67 22 20 20 20 20 20 20 20 20 20 20 2e nfig" .
2530: 20 68 29 0a 20 20 20 20 28 22 2d 74 69 6d 65 2d h). ("-time-
2540: 6f 75 74 22 20 20 20 20 20 20 20 20 2e 20 75 29 out" . u)
2550: 0a 20 20 20 20 28 22 2d 61 72 63 68 69 76 65 22 . ("-archive"
2560: 20 20 20 20 20 20 20 20 20 2e 20 62 29 0a 20 20 . b).
2570: 20 20 29 29 0a 28 64 65 66 69 6e 65 20 2a 73 77 )).(define *sw
2580: 69 74 63 68 2d 6b 65 79 73 2a 0a 20 20 27 28 0a itch-keys*. '(.
2590: 20 20 20 20 28 22 2d 68 22 20 20 20 20 20 20 20 ("-h"
25a0: 20 20 20 20 20 20 20 20 2e 20 23 66 29 0a 20 20 . #f).
25b0: 20 20 28 22 2d 68 65 6c 70 22 20 20 20 20 20 20 ("-help"
25c0: 20 20 20 20 20 20 2e 20 23 66 29 0a 20 20 20 20 . #f).
25d0: 28 22 2d 2d 68 65 6c 70 22 20 20 20 20 20 20 20 ("--help"
25e0: 20 20 20 20 2e 20 23 66 29 0a 20 20 20 20 28 22 . #f). ("
25f0: 2d 6d 61 6e 75 61 6c 22 20 20 20 20 20 20 20 20 -manual"
2600: 20 20 2e 20 23 66 29 0a 20 20 20 20 28 22 2d 76 . #f). ("-v
2610: 65 72 73 69 6f 6e 22 20 20 20 20 20 20 20 20 20 ersion"
2620: 2e 20 23 66 29 0a 20 20 20 20 3b 3b 20 6d 69 73 . #f). ;; mis
2630: 63 09 20 20 20 20 20 20 20 20 0a 20 20 20 20 28 c. . (
2640: 22 2d 72 65 70 6c 22 20 20 20 20 20 20 20 20 20 "-repl"
2650: 20 20 20 2e 20 23 66 29 0a 20 20 20 20 28 22 2d . #f). ("-
2660: 69 6d 6d 65 64 69 61 74 65 22 20 20 20 20 20 20 immediate"
2670: 20 2e 20 49 29 0a 20 20 20 20 28 22 2d 70 72 65 . I). ("-pre
2680: 63 6c 65 61 6e 22 20 20 20 20 20 20 20 20 2e 20 clean" .
2690: 72 29 0a 20 20 20 20 28 22 2d 70 72 65 70 65 6e r). ("-prepen
26a0: 64 2d 63 6f 6e 74 6f 75 72 22 20 2e 20 77 29 0a d-contour" . w).
26b0: 20 20 20 20 28 22 2d 66 6f 72 63 65 22 20 20 20 ("-force"
26c0: 20 20 20 20 20 20 20 20 2e 20 46 29 0a 20 20 20 . F).
26d0: 20 28 22 2d 6c 69 73 74 2d 70 6b 74 2d 6b 65 79 ("-list-pkt-key
26e0: 73 22 20 20 20 2e 20 23 66 29 0a 20 20 20 20 29 s" . #f). )
26f0: 29 0a 0a 3b 3b 20 61 6c 69 73 74 20 74 6f 20 6d )..;; alist to m
2700: 61 70 20 61 63 74 69 6f 6e 73 20 74 6f 20 6f 6c ap actions to ol
2710: 64 20 6d 65 67 61 74 65 73 74 20 63 6f 6d 6d 61 d megatest comma
2720: 6e 64 73 0a 28 64 65 66 69 6e 65 20 2a 61 63 74 nds.(define *act
2730: 69 6f 6e 2d 6b 65 79 73 2a 0a 20 20 27 28 28 72 ion-keys*. '((r
2740: 75 6e 20 20 20 20 20 20 20 20 20 2e 20 22 2d 72 un . "-r
2750: 75 6e 22 29 0a 20 20 20 20 28 72 65 72 75 6e 2d un"). (rerun-
2760: 63 6c 65 61 6e 20 2e 20 22 2d 72 65 72 75 6e 2d clean . "-rerun-
2770: 63 6c 65 61 6e 22 29 0a 20 20 20 20 28 72 65 72 clean"). (rer
2780: 75 6e 2d 61 6c 6c 20 20 20 2e 20 22 2d 72 65 72 un-all . "-rer
2790: 75 6e 2d 61 6c 6c 22 29 0a 20 20 20 20 28 6b 69 un-all"). (ki
27a0: 6c 6c 2d 72 75 6e 20 20 20 20 2e 20 22 2d 6b 69 ll-run . "-ki
27b0: 6c 6c 2d 72 75 6e 73 22 29 0a 20 20 20 20 28 6b ll-runs"). (k
27c0: 69 6c 6c 2d 72 65 72 75 6e 20 20 2e 20 22 2d 6b ill-rerun . "-k
27d0: 69 6c 6c 2d 72 65 72 75 6e 22 29 0a 20 20 20 20 ill-rerun").
27e0: 28 6c 6f 63 6b 20 20 20 20 20 20 20 20 2e 20 22 (lock . "
27f0: 2d 6c 6f 63 6b 22 29 0a 20 20 20 20 28 75 6e 6c -lock"). (unl
2800: 6f 63 6b 20 20 20 20 20 20 2e 20 22 2d 75 6e 6c ock . "-unl
2810: 6f 63 6b 22 29 0a 20 20 20 20 28 73 79 6e 63 20 ock"). (sync
2820: 20 20 20 20 20 20 20 2e 20 22 22 29 0a 20 20 20 . "").
2830: 20 28 61 72 63 68 69 76 65 20 20 20 20 20 2e 20 (archive .
2840: 22 22 29 0a 20 20 20 20 28 73 65 74 2d 73 73 20 ""). (set-ss
2850: 20 20 20 20 20 2e 20 22 2d 73 65 74 2d 73 74 61 . "-set-sta
2860: 74 65 2d 73 74 61 74 75 73 22 29 0a 20 20 20 20 te-status").
2870: 28 72 65 6d 6f 76 65 20 20 20 20 20 20 2e 20 22 (remove . "
2880: 2d 72 65 6d 6f 76 65 2d 72 75 6e 73 22 29 29 29 -remove-runs")))
2890: 0a 0a 3b 3b 20 6d 61 6e 75 61 6c 6c 79 20 6b 65 ..;; manually ke
28a0: 65 70 20 74 68 69 73 20 6c 69 73 74 20 75 70 64 ep this list upd
28b0: 61 74 65 64 20 66 72 6f 6d 20 74 68 65 20 6b 65 ated from the ke
28c0: 79 73 20 74 6f 0a 3b 3b 20 74 68 65 20 63 61 73 ys to.;; the cas
28d0: 65 20 2a 61 63 74 69 6f 6e 2a 20 6e 65 61 72 20 e *action* near
28e0: 74 68 65 20 65 6e 64 20 6f 66 20 74 68 69 73 20 the end of this
28f0: 66 69 6c 65 2e 0a 28 64 65 66 69 6e 65 20 2a 6f file..(define *o
2900: 74 68 65 72 2d 61 63 74 69 6f 6e 73 2a 0a 20 20 ther-actions*.
2910: 27 28 72 75 6e 20 72 65 6d 6f 76 65 20 72 65 72 '(run remove rer
2920: 75 6e 20 73 65 74 2d 73 73 20 61 72 63 68 69 76 un set-ss archiv
2930: 65 20 6b 69 6c 6c 20 6c 69 73 74 0a 09 64 69 73 e kill list..dis
2940: 70 61 74 63 68 20 69 6d 70 6f 72 74 20 72 75 6e patch import run
2950: 67 65 6e 20 70 72 6f 63 65 73 73 0a 09 73 68 6f gen process..sho
2960: 77 20 67 65 6e 64 6f 74 20 64 62 20 74 73 65 6e w gendot db tsen
2970: 64 20 74 6c 69 73 74 65 6e 29 29 0a 0a 3b 3b 20 d tlisten))..;;
2980: 43 61 72 64 20 74 79 70 65 73 3a 0a 3b 3b 0a 3b Card types:.;;.;
2990: 3b 20 41 20 61 63 74 69 6f 6e 0a 3b 3b 20 55 20 ; A action.;; U
29a0: 75 73 65 72 6e 61 6d 65 20 28 55 6e 69 78 29 0a username (Unix).
29b0: 3b 3b 20 44 20 74 69 6d 65 73 74 61 6d 70 0a 3b ;; D timestamp.;
29c0: 3b 20 54 20 63 61 72 64 20 74 79 70 65 0a 0a 3b ; T card type..;
29d0: 3b 20 61 20 73 75 6d 6d 61 72 79 20 6c 69 73 74 ; a summary list
29e0: 20 6f 66 20 75 73 65 64 20 63 61 72 64 20 74 79 of used card ty
29f0: 70 65 73 20 66 6f 72 20 68 65 6c 70 69 6e 67 20 pes for helping
2a00: 74 6f 20 6e 6f 74 20 61 63 63 69 64 65 6e 74 61 to not accidenta
2a10: 6c 6c 79 20 72 65 2d 75 73 65 20 74 68 65 6d 0a lly re-use them.
2a20: 3b 3b 0a 3b 3b 20 41 44 47 49 4d 53 54 55 5a 61 ;;.;; ADGIMSTUZa
2a30: 62 63 64 65 66 67 68 69 6b 6c 6e 6f 70 72 73 74 bcdefghiklnoprst
2a40: 75 76 77 78 0a 0a 3b 3b 20 75 74 69 6c 69 74 61 uvwx..;; utilita
2a50: 72 69 61 6e 20 61 6c 69 73 74 20 66 6f 72 20 73 rian alist for s
2a60: 74 61 6e 64 61 72 64 20 63 61 72 64 73 0a 3b 3b tandard cards.;;
2a70: 0a 28 64 65 66 69 6e 65 20 2a 61 64 64 69 74 69 .(define *additi
2a80: 6f 6e 61 6c 2d 63 61 72 64 73 2a 0a 20 20 27 28 onal-cards*. '(
2a90: 0a 20 20 20 20 3b 3b 20 53 74 61 6e 64 61 72 64 . ;; Standard
2aa0: 20 43 61 72 64 73 0a 20 20 20 20 28 41 20 20 2e Cards. (A .
2ab0: 20 61 63 74 69 6f 6e 20 20 20 20 29 0a 20 20 20 action ).
2ac0: 20 28 44 20 20 2e 20 74 69 6d 65 73 74 61 6d 70 (D . timestamp
2ad0: 20 29 0a 20 20 20 20 28 54 20 20 2e 20 63 61 72 ). (T . car
2ae0: 64 74 79 70 65 20 20 29 0a 20 20 20 20 28 55 20 dtype ). (U
2af0: 20 2e 20 75 73 65 72 20 20 20 20 20 20 29 20 3b . user ) ;
2b00: 3b 20 75 73 65 72 6e 61 6d 65 0a 20 20 20 20 28 ; username. (
2b10: 5a 20 20 2e 20 73 68 61 72 31 73 75 6d 20 20 29 Z . shar1sum )
2b20: 0a 0a 20 20 20 20 3b 3b 20 45 78 74 72 61 73 0a .. ;; Extras.
2b30: 20 20 20 20 28 61 20 20 2e 20 72 75 6e 6b 65 79 (a . runkey
2b40: 20 20 20 20 29 20 3b 3b 20 6e 65 65 64 65 64 20 ) ;; needed
2b50: 66 6f 72 20 6d 61 74 63 68 69 6e 67 20 75 70 20 for matching up
2b60: 70 6b 74 73 20 77 69 74 68 20 74 61 72 67 65 74 pkts with target
2b70: 20 64 65 72 69 76 65 64 20 66 72 6f 6d 20 72 75 derived from ru
2b80: 6e 6b 65 79 0a 20 20 20 20 3b 3b 20 28 6c 20 20 nkey. ;; (l
2b90: 2e 20 6e 65 77 2d 73 73 20 20 20 20 29 20 3b 3b . new-ss ) ;;
2ba0: 20 6e 65 77 20 73 74 61 74 65 2f 73 74 61 74 75 new state/statu
2bb0: 73 0a 20 20 20 20 28 62 20 20 2e 20 62 72 61 6e s. (b . bran
2bc0: 63 68 20 20 20 20 29 20 3b 3b 20 72 65 70 6f 73 ch ) ;; repos
2bd0: 69 74 6f 72 79 20 62 72 61 6e 63 68 20 6f 72 20 itory branch or
2be0: 74 61 67 20 28 66 6f 73 73 69 6c 20 6f 72 20 67 tag (fossil or g
2bf0: 69 74 29 0a 20 20 20 20 28 66 20 20 2e 20 75 72 it). (f . ur
2c00: 6c 20 20 20 20 20 20 20 29 20 3b 3b 20 72 65 70 l ) ;; rep
2c10: 6f 73 69 74 6f 72 79 20 55 52 4c 20 28 65 2e 67 ository URL (e.g
2c20: 2e 20 66 6f 73 73 69 6c 20 6f 72 20 67 69 74 29 . fossil or git)
2c30: 0a 20 20 20 20 28 67 20 20 2e 20 63 6c 6f 6e 65 . (g . clone
2c40: 20 20 20 20 20 29 20 3b 3b 20 65 78 69 73 74 69 ) ;; existi
2c50: 6e 67 20 63 6c 6f 6e 65 20 61 72 65 61 20 28 63 ng clone area (c
2c60: 61 63 68 65 64 20 69 6e 20 2f 74 6d 70 29 0a 20 ached in /tmp).
2c70: 20 20 20 29 29 0a 0a 3b 3b 20 69 6e 6c 73 74 20 ))..;; inlst
2c80: 69 73 20 61 6e 20 61 6c 74 65 72 6e 61 74 69 76 is an alternativ
2c90: 65 20 69 6e 70 75 74 0a 3b 3b 0a 28 64 65 66 69 e input.;;.(defi
2ca0: 6e 65 20 28 6c 6f 6f 6b 75 70 2d 70 61 72 61 6d ne (lookup-param
2cb0: 2d 62 79 2d 6b 65 79 20 6b 65 79 20 23 21 6b 65 -by-key key #!ke
2cc0: 79 20 28 69 6e 6c 73 74 20 23 66 29 29 0a 20 20 y (inlst #f)).
2cd0: 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 (fold (lambda (a
2ce0: 20 72 65 73 29 0a 09 20 20 28 69 66 20 28 65 71 res).. (if (eq
2cf0: 3f 20 28 63 64 72 20 61 29 20 6b 65 79 29 0a 09 ? (cdr a) key)..
2d00: 20 20 20 20 20 20 28 63 61 72 20 61 29 0a 09 20 (car a)..
2d10: 20 20 20 20 20 72 65 73 29 29 0a 09 23 66 0a 09 res))..#f..
2d20: 28 6f 72 20 69 6e 6c 73 74 20 2a 61 72 67 2d 6b (or inlst *arg-k
2d30: 65 79 73 2a 29 29 29 0a 0a 28 64 65 66 69 6e 65 eys*)))..(define
2d40: 20 28 6c 6f 6f 6b 75 70 2d 61 63 74 69 6f 6e 2d (lookup-action-
2d50: 62 79 2d 6b 65 79 20 6b 65 79 29 0a 20 20 28 61 by-key key). (a
2d60: 6c 69 73 74 2d 72 65 66 20 28 73 74 72 69 6e 67 list-ref (string
2d70: 2d 3e 73 79 6d 62 6f 6c 20 6b 65 79 29 20 2a 61 ->symbol key) *a
2d80: 63 74 69 6f 6e 2d 6b 65 79 73 2a 29 29 0a 0a 28 ction-keys*))..(
2d90: 64 65 66 69 6e 65 20 28 73 77 69 7a 7a 6c 65 2d define (swizzle-
2da0: 61 6c 69 73 74 20 6c 73 74 29 0a 20 20 28 6d 61 alist lst). (ma
2db0: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f p (lambda (x)(co
2dc0: 6e 73 20 28 63 64 72 20 78 29 28 63 61 72 20 78 ns (cdr x)(car x
2dd0: 29 29 29 20 6c 73 74 29 29 0a 0a 3b 3b 3d 3d 3d ))) lst))..;;===
2de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e20: 3d 3d 3d 0a 3b 3b 20 20 55 20 54 20 49 20 4c 20 ===.;; U T I L
2e30: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
2e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 67 ==========..;; g
2e80: 69 76 65 6e 20 61 20 6d 74 75 74 69 6c 20 70 61 iven a mtutil pa
2e90: 72 61 6d 2c 20 72 65 74 75 72 6e 20 74 68 65 20 ram, return the
2ea0: 6f 6c 64 20 6d 65 67 61 74 65 73 74 20 65 71 75 old megatest equ
2eb0: 69 76 61 6c 65 6e 74 0a 3b 3b 0a 28 64 65 66 69 ivalent.;;.(defi
2ec0: 6e 65 20 28 6d 65 67 61 74 65 73 74 2d 70 61 72 ne (megatest-par
2ed0: 61 6d 2d 3e 6d 74 75 74 69 6c 2d 70 61 72 61 6d am->mtutil-param
2ee0: 20 70 61 72 61 6d 29 0a 20 20 28 6c 65 74 2a 20 param). (let*
2ef0: 28 28 6d 61 70 70 69 6e 67 2d 61 6c 69 73 74 20 ((mapping-alist
2f00: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 61 72 61 (common:get-para
2f10: 6d 2d 6d 61 70 70 69 6e 67 20 66 6c 61 76 6f 72 m-mapping flavor
2f20: 3a 20 27 73 77 69 74 63 68 2d 73 79 6d 62 6f 6c : 'switch-symbol
2f30: 29 29 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 72 ))). (alist-r
2f40: 65 66 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 ef (string->symb
2f50: 6f 6c 20 70 61 72 61 6d 29 20 6d 61 70 70 69 6e ol param) mappin
2f60: 67 2d 61 6c 69 73 74 20 65 71 3f 20 70 61 72 61 g-alist eq? para
2f70: 6d 29 0a 20 20 20 20 70 61 72 61 6d 29 29 0a 0a m). param))..
2f80: 28 64 65 66 69 6e 65 20 76 61 6c 2d 3e 61 6c 69 (define val->ali
2f90: 73 74 20 63 6f 6d 6d 6f 6e 3a 76 61 6c 2d 3e 61 st common:val->a
2fa0: 6c 69 73 74 29 0a 0a 28 64 65 66 69 6e 65 20 28 list)..(define (
2fb0: 70 75 73 68 2d 72 75 6e 2d 73 70 65 63 20 74 6f push-run-spec to
2fc0: 72 75 6e 20 63 6f 6e 74 6f 75 72 20 72 75 6e 6b run contour runk
2fd0: 65 79 20 73 70 65 63 29 0a 20 20 28 63 6f 6e 66 ey spec). (conf
2fe0: 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 72 2d igf:section-var-
2ff0: 73 65 74 21 20 74 6f 72 75 6e 20 63 6f 6e 74 6f set! torun conto
3000: 75 72 20 72 75 6e 6b 65 79 0a 09 09 09 20 20 20 ur runkey....
3010: 20 28 63 6f 6e 73 20 73 70 65 63 0a 09 09 09 09 (cons spec.....
3020: 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c (or (configf:l
3030: 6f 6f 6b 75 70 20 74 6f 72 75 6e 20 63 6f 6e 74 ookup torun cont
3040: 6f 75 72 20 72 75 6e 6b 65 79 29 0a 09 09 09 09 our runkey).....
3050: 20 20 20 20 20 20 27 28 29 29 29 29 29 0a 0a 28 '()))))..(
3060: 64 65 66 69 6e 65 20 28 66 6f 73 73 69 6c 3a 63 define (fossil:c
3070: 6c 6f 6e 65 2d 6f 72 2d 73 79 6e 63 20 75 72 6c lone-or-sync url
3080: 20 6e 61 6d 65 20 64 65 73 74 2d 64 69 72 29 0a name dest-dir).
3090: 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 66 69 (let ((targ-fi
30a0: 6c 65 20 28 63 6f 6e 63 20 64 65 73 74 2d 64 69 le (conc dest-di
30b0: 72 20 22 2f 22 20 6e 61 6d 65 29 29 29 20 3b 3b r "/" name))) ;;
30c0: 20 64 6f 20 6e 6f 74 20 66 6f 72 63 65 20 75 73 do not force us
30d0: 61 67 65 20 6f 66 20 2e 66 6f 73 73 69 6c 20 65 age of .fossil e
30e0: 78 74 65 6e 73 69 6f 6e 0a 20 20 20 20 28 68 61 xtension. (ha
30f0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
3100: 09 65 78 6e 0a 09 28 70 72 69 6e 74 20 22 45 52 .exn..(print "ER
3110: 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 63 ROR: failed to c
3120: 72 65 61 74 65 20 64 69 72 65 63 74 6f 72 79 20 reate directory
3130: 22 20 64 65 73 74 2d 64 69 72 20 22 20 6d 65 73 " dest-dir " mes
3140: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
3150: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
3160: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
3170: 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 age) exn)).
3180: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
3190: 72 79 20 64 65 73 74 2d 64 69 72 20 23 74 29 29 ry dest-dir #t))
31a0: 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
31b0: 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 70 eptions..exn..(p
31c0: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 69 rint "ERROR: fai
31d0: 6c 65 64 20 74 6f 20 63 6c 6f 6e 65 20 6f 72 20 led to clone or
31e0: 73 79 6e 63 20 31 6f 73 73 69 6c 20 22 20 75 72 sync 1ossil " ur
31f0: 6c 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 l " message: " (
3200: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
3210: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
3220: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
3230: 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d ). (if (com
3240: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
3250: 20 74 61 72 67 2d 66 69 6c 65 29 0a 09 20 20 28 targ-file).. (
3260: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 66 6f system (conc "fo
3270: 73 73 69 6c 20 70 75 6c 6c 20 2d 2d 6f 6e 63 65 ssil pull --once
3280: 20 22 20 75 72 6c 20 22 20 2d 52 20 22 20 74 61 " url " -R " ta
3290: 72 67 2d 66 69 6c 65 29 29 0a 09 20 20 28 73 79 rg-file)).. (sy
32a0: 73 74 65 6d 20 28 63 6f 6e 63 20 22 66 6f 73 73 stem (conc "foss
32b0: 69 6c 20 63 6c 6f 6e 65 20 22 20 75 72 6c 20 22 il clone " url "
32c0: 20 22 20 74 61 72 67 2d 66 69 6c 65 29 29 0a 09 " targ-file))..
32d0: 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))..(define
32e0: 28 66 6f 73 73 69 6c 3a 6c 61 73 74 2d 63 68 61 (fossil:last-cha
32f0: 6e 67 65 2d 6e 6f 64 65 2d 61 6e 64 2d 74 69 6d nge-node-and-tim
3300: 65 20 66 6f 73 73 69 6c 73 2d 64 69 72 20 66 6f e fossils-dir fo
3310: 73 73 69 6c 2d 6e 61 6d 65 20 62 72 61 6e 63 68 ssil-name branch
3320: 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 6f 73 73 ). (let* ((foss
3330: 69 6c 2d 66 69 6c 65 20 20 20 28 63 6f 6e 63 20 il-file (conc
3340: 66 6f 73 73 69 6c 73 2d 64 69 72 20 22 2f 22 20 fossils-dir "/"
3350: 66 6f 73 73 69 6c 2d 6e 61 6d 65 29 29 0a 09 20 fossil-name))..
3360: 28 74 69 6d 65 6c 69 6e 65 2d 70 6f 72 74 20 28 (timeline-port (
3370: 69 66 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 if (file-read-ac
3380: 63 65 73 73 3f 20 66 6f 73 73 69 6c 2d 66 69 6c cess? fossil-fil
3390: 65 29 0a 09 09 09 20 20 20 20 28 68 61 6e 64 6c e).... (handl
33a0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
33b0: 09 65 78 6e 0a 09 09 09 09 28 62 65 67 69 6e 0a .exn.....(begin.
33c0: 09 09 09 09 20 20 28 70 72 69 6e 74 20 22 45 52 .... (print "ER
33d0: 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 67 ROR: failed to g
33e0: 65 74 20 74 69 6d 65 6c 69 6e 65 20 66 72 6f 6d et timeline from
33f0: 20 22 20 66 6f 73 73 69 6c 2d 66 69 6c 65 20 22 " fossil-file "
3400: 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f message: " ((co
3410: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
3420: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
3430: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 message) exn))..
3440: 09 09 09 20 20 23 66 29 0a 09 09 09 20 20 20 20 ... #f)....
3450: 20 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 (open-input-pi
3460: 70 65 20 28 63 6f 6e 63 20 22 66 6f 73 73 69 6c pe (conc "fossil
3470: 20 74 69 6d 65 6c 69 6e 65 20 2d 74 20 63 69 20 timeline -t ci
3480: 2d 57 20 30 20 2d 6e 20 30 20 2d 52 20 22 20 66 -W 0 -n 0 -R " f
3490: 6f 73 73 69 6c 2d 66 69 6c 65 29 29 29 0a 09 09 ossil-file)))...
34a0: 09 20 20 20 20 23 66 29 29 0a 09 20 28 67 65 74 . #f)).. (get
34b0: 2d 6c 69 6e 65 20 20 20 20 20 20 28 6c 61 6d 62 -line (lamb
34c0: 64 61 20 28 29 0a 09 09 09 20 20 28 68 61 6e 64 da ().... (hand
34d0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
34e0: 09 20 20 20 20 20 20 65 78 6e 0a 09 09 09 20 20 . exn....
34f0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 (begin.....(
3500: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 print "ERROR: fa
3510: 69 6c 65 64 20 74 6f 20 72 65 61 64 20 66 72 6f iled to read fro
3520: 6d 20 66 69 6c 65 20 22 20 66 6f 73 73 69 6c 2d m file " fossil-
3530: 66 69 6c 65 20 22 20 6d 65 73 73 61 67 65 3a 20 file " message:
3540: 22 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
3550: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
3560: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
3570: 65 78 6e 29 29 0a 09 09 09 09 23 66 29 0a 09 09 exn)).....#f)...
3580: 09 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 20 . (read-line
3590: 74 69 6d 65 6c 69 6e 65 2d 70 6f 72 74 29 29 29 timeline-port)))
35a0: 29 0a 09 20 28 64 61 74 65 2d 72 78 20 20 20 20 ).. (date-rx
35b0: 20 20 20 28 72 65 67 65 78 70 20 22 5e 3d 3d 3d (regexp "^===
35c0: 20 28 5c 5c 53 2b 29 20 3d 3d 3d 24 22 29 29 0a (\\S+) ===$")).
35d0: 09 20 28 6e 6f 64 65 2d 72 78 20 20 20 20 20 20 . (node-rx
35e0: 20 28 72 65 67 65 78 70 20 22 5e 28 5c 5c 53 2b (regexp "^(\\S+
35f0: 29 20 5c 5c 5b 28 5c 5c 53 2b 29 5c 5c 5d 2e 2a ) \\[(\\S+)\\].*
3600: 5c 5c 28 2e 2a 74 61 67 73 3a 5c 5c 73 2b 28 5b \\(.*tags:\\s+([
3610: 5e 5c 5c 29 5d 2b 29 5c 5c 29 24 22 29 29 29 0a ^\\)]+)\\)$"))).
3620: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
3630: 69 6e 6c 20 28 67 65 74 2d 6c 69 6e 65 29 29 0a inl (get-line)).
3640: 09 20 20 20 20 20 20 20 28 64 61 74 65 20 23 66 . (date #f
3650: 29 0a 09 20 20 20 20 20 20 20 28 6e 6f 64 65 20 ).. (node
3660: 23 66 29 0a 09 20 20 20 20 20 20 20 28 74 69 6d #f).. (tim
3670: 65 20 23 66 29 29 0a 20 20 20 20 20 20 28 63 6f e #f)). (co
3680: 6e 64 0a 20 20 20 20 20 20 20 28 28 61 6e 64 20 nd. ((and
3690: 64 61 74 65 20 74 69 6d 65 20 6e 6f 64 65 29 20 date time node)
36a0: 3b 3b 20 68 61 76 65 20 61 6c 6c 2c 20 72 65 74 ;; have all, ret
36b0: 75 72 6e 20 27 65 6d 0a 09 28 63 6c 6f 73 65 2d urn 'em..(close-
36c0: 69 6e 70 75 74 2d 70 6f 72 74 20 74 69 6d 65 6c input-port timel
36d0: 69 6e 65 2d 70 6f 72 74 29 0a 09 28 76 61 6c 75 ine-port)..(valu
36e0: 65 73 20 28 63 6f 6d 6d 6f 6e 3a 64 61 74 65 2d es (common:date-
36f0: 74 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 28 63 time->seconds (c
3700: 6f 6e 63 20 64 61 74 65 20 22 20 22 20 74 69 6d onc date " " tim
3710: 65 29 29 20 6e 6f 64 65 29 29 0a 20 20 20 20 20 e)) node)).
3720: 20 20 28 28 61 6e 64 20 69 6e 6c 20 28 6e 6f 74 ((and inl (not
3730: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e (eof-object? in
3740: 6c 29 29 29 20 3b 3b 20 68 61 76 65 20 61 20 6c l))) ;; have a l
3750: 69 6e 65 20 74 6f 20 70 72 6f 63 65 73 73 0a 09 ine to process..
3760: 28 72 65 67 65 78 2d 63 61 73 65 20 69 6e 6c 0a (regex-case inl.
3770: 09 20 20 28 64 61 74 65 2d 72 78 20 28 20 5f 20 . (date-rx ( _
3780: 6e 65 77 64 61 74 65 20 29 20 28 6c 6f 6f 70 20 newdate ) (loop
3790: 28 67 65 74 2d 6c 69 6e 65 29 20 6e 65 77 64 61 (get-line) newda
37a0: 74 65 20 6e 6f 64 65 20 74 69 6d 65 29 29 0a 09 te node time))..
37b0: 20 20 3b 3b 20 32 32 3a 34 37 3a 34 38 20 5b 61 ;; 22:47:48 [a
37c0: 30 32 34 64 39 65 36 30 66 5d 20 41 64 64 65 64 024d9e60f] Added
37d0: 20 2a 75 73 65 72 2d 68 61 73 68 2d 64 61 74 61 *user-hash-data
37e0: 2a 20 2d 20 61 20 67 6c 6f 62 61 6c 20 74 68 61 * - a global tha
37f0: 74 20 63 61 6e 20 62 65 20 75 73 65 64 20 69 6e t can be used in
3800: 20 2d 72 65 70 6c 20 61 6e 64 20 23 7b 73 63 68 -repl and #{sch
3810: 65 6d 65 20 2e 2e 2e 7d 20 63 61 6c 6c 73 20 62 eme ...} calls b
3820: 79 20 74 68 65 20 65 6e 64 20 75 73 65 72 20 28 y the end user (
3830: 75 73 65 72 3a 20 6d 61 74 74 20 74 61 67 73 3a user: matt tags:
3840: 20 76 31 2e 36 33 29 0a 09 20 20 28 6e 6f 64 65 v1.63).. (node
3850: 2d 72 78 20 28 20 5f 20 6e 65 77 74 69 6d 65 20 -rx ( _ newtime
3860: 6e 65 77 6e 6f 64 65 20 61 6c 6c 74 61 67 73 20 newnode alltags
3870: 29 0a 09 09 20 20 20 28 6c 65 74 20 28 28 74 61 )... (let ((ta
3880: 67 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 gs (string-split
3890: 2d 66 69 65 6c 64 73 20 22 2c 5c 5c 73 2a 22 20 -fields ",\\s*"
38a0: 61 6c 6c 74 61 67 73 20 23 3a 69 6e 66 69 78 29 alltags #:infix)
38b0: 29 29 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 ))... (print
38c0: 20 22 74 61 67 73 3a 20 22 20 74 61 67 73 29 0a "tags: " tags).
38d0: 09 09 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 .. (if (memb
38e0: 65 72 20 62 72 61 6e 63 68 20 74 61 67 73 29 0a er branch tags).
38f0: 09 09 09 20 28 6c 6f 6f 70 20 28 67 65 74 2d 6c ... (loop (get-l
3900: 69 6e 65 29 20 64 61 74 65 20 6e 65 77 6e 6f 64 ine) date newnod
3910: 65 20 6e 65 77 74 69 6d 65 29 0a 09 09 09 20 28 e newtime).... (
3920: 6c 6f 6f 70 20 28 67 65 74 2d 6c 69 6e 65 29 20 loop (get-line)
3930: 64 61 74 65 20 6e 6f 64 65 20 74 69 6d 65 29 29 date node time))
3940: 29 29 0a 09 20 20 28 65 6c 73 65 20 3b 3b 20 68 )).. (else ;; h
3950: 61 76 65 20 73 6f 6d 65 20 75 6e 72 65 63 6f 67 ave some unrecog
3960: 6e 69 73 65 64 20 6a 75 6e 6b 3f 20 73 70 69 74 nised junk? spit
3970: 20 6f 75 74 20 65 72 72 6f 72 20 6d 65 73 73 61 out error messa
3980: 67 65 0a 09 20 20 20 28 70 72 69 6e 74 20 22 45 ge.. (print "E
3990: 52 52 4f 52 3a 20 66 6f 73 73 69 6c 20 74 69 6d RROR: fossil tim
39a0: 65 6c 69 6e 65 20 72 65 74 75 72 6e 65 64 20 75 eline returned u
39b0: 6e 72 65 63 6f 67 6e 69 73 61 62 6c 65 20 6a 75 nrecognisable ju
39c0: 6e 6b 20 5c 22 22 20 69 6e 6c 20 22 5c 22 22 29 nk \"" inl "\"")
39d0: 0a 09 20 20 20 28 6c 6f 6f 70 20 28 67 65 74 2d .. (loop (get-
39e0: 6c 69 6e 65 29 20 64 61 74 65 20 6e 6f 64 65 20 line) date node
39f0: 74 69 6d 65 29 29 29 29 0a 20 20 20 20 20 20 20 time)))).
3a00: 28 65 6c 73 65 20 3b 3b 20 6e 6f 20 6d 6f 72 65 (else ;; no more
3a10: 20 64 61 74 61 74 20 61 6e 64 20 6c 61 73 74 20 datat and last
3a20: 6e 6f 64 65 20 6f 6e 20 62 72 61 6e 63 68 20 6e node on branch n
3a30: 6f 74 20 66 6f 75 6e 64 0a 09 28 63 6c 6f 73 65 ot found..(close
3a40: 2d 69 6e 70 75 74 2d 70 6f 72 74 20 74 69 6d 65 -input-port time
3a50: 6c 69 6e 65 2d 70 6f 72 74 29 0a 09 28 76 61 6c line-port)..(val
3a60: 75 65 73 20 20 28 63 6f 6d 6d 6f 6e 3a 64 61 74 ues (common:dat
3a70: 65 2d 74 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 e-time->seconds
3a80: 28 63 6f 6e 63 20 64 61 74 65 20 22 20 22 20 74 (conc date " " t
3a90: 69 6d 65 29 29 20 6e 6f 64 65 29 29 29 29 29 29 ime)) node))))))
3aa0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
3ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 47 4c ==========.;; GL
3af0: 4f 42 41 4c 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d OBALS.;;========
3b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
3b40: 3b 3b 20 66 69 72 73 74 20 74 6f 6b 65 6e 20 69 ;; first token i
3b50: 73 20 6f 75 72 20 61 63 74 69 6f 6e 2c 20 62 75 s our action, bu
3b60: 74 20 6f 6e 6c 79 20 69 66 20 6e 6f 20 6c 65 61 t only if no lea
3b70: 64 69 6e 67 20 64 61 73 68 0a 28 64 65 66 69 6e ding dash.(defin
3b80: 65 20 2a 61 63 74 69 6f 6e 2a 20 28 69 66 20 28 e *action* (if (
3b90: 61 6e 64 20 28 3e 20 28 6c 65 6e 67 74 68 20 28 and (> (length (
3ba0: 61 72 67 76 29 29 20 31 29 0a 20 20 20 20 20 20 argv)) 1).
3bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bc0: 20 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 (not (string
3bd0: 2d 6d 61 74 63 68 20 22 5e 5c 5c 2d 2e 2a 22 20 -match "^\\-.*"
3be0: 28 63 61 64 72 20 28 61 72 67 76 29 29 29 29 29 (cadr (argv)))))
3bf0: 0a 09 09 20 20 20 20 20 28 63 61 64 72 20 28 61 ... (cadr (a
3c00: 72 67 76 29 29 0a 09 09 20 20 20 20 20 23 66 29 rgv))... #f)
3c10: 29 0a 0a 3b 3b 20 70 72 6f 63 65 73 73 20 61 72 )..;; process ar
3c20: 67 75 6d 65 6e 74 73 2c 20 65 78 74 72 61 63 74 guments, extract
3c30: 20 73 77 69 74 63 68 65 73 20 61 6e 64 20 70 61 switches and pa
3c40: 72 61 6d 65 74 65 72 73 20 66 69 72 73 74 0a 28 rameters first.(
3c50: 64 65 66 69 6e 65 20 72 65 6d 61 72 67 73 20 28 define remargs (
3c60: 61 72 67 73 3a 67 65 74 2d 61 72 67 73 20 0a 09 args:get-args ..
3c70: 09 20 28 69 66 20 2a 61 63 74 69 6f 6e 2a 20 28 . (if *action* (
3c80: 63 64 72 20 28 61 72 67 76 29 29 20 28 61 72 67 cdr (argv)) (arg
3c90: 76 29 29 20 3b 3b 20 61 72 67 73 3a 67 65 74 2d v)) ;; args:get-
3ca0: 61 72 67 73 20 64 75 6d 70 73 20 66 69 72 73 74 args dumps first
3cb0: 20 69 6e 20 61 72 67 76 20 6c 69 73 74 20 28 74 in argv list (t
3cc0: 68 65 20 70 72 6f 67 72 61 6d 20 6e 61 6d 65 29 he program name)
3cd0: 0a 09 09 20 28 6d 61 70 20 63 61 72 20 2a 61 72 ... (map car *ar
3ce0: 67 2d 6b 65 79 73 2a 29 0a 09 09 20 28 6d 61 70 g-keys*)... (map
3cf0: 20 63 61 72 20 2a 73 77 69 74 63 68 2d 6b 65 79 car *switch-key
3d00: 73 2a 29 0a 09 09 20 61 72 67 73 3a 61 72 67 2d s*)... args:arg-
3d10: 68 61 73 68 0a 09 09 20 30 29 29 0a 0a 3b 3b 20 hash... 0))..;;
3d20: 68 61 6e 64 6c 65 20 72 65 71 75 65 73 74 73 20 handle requests
3d30: 66 6f 72 20 68 65 6c 70 0a 3b 3b 0a 28 69 66 20 for help.;;.(if
3d40: 28 6f 72 20 28 6d 65 6d 62 65 72 20 2a 61 63 74 (or (member *act
3d50: 69 6f 6e 2a 20 27 28 22 2d 68 22 20 22 2d 68 65 ion* '("-h" "-he
3d60: 6c 70 22 20 22 68 65 6c 70 22 20 22 2d 2d 68 65 lp" "help" "--he
3d70: 6c 70 22 29 29 0a 09 28 61 72 67 73 3a 61 6e 79 lp"))..(args:any
3d80: 2d 64 65 66 69 6e 65 64 3f 20 22 2d 68 22 20 22 -defined? "-h" "
3d90: 2d 68 65 6c 70 22 20 22 2d 2d 68 65 6c 70 22 29 -help" "--help")
3da0: 29 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 ). (begin.
3db0: 20 20 20 28 70 72 69 6e 74 20 68 65 6c 70 29 0a (print help).
3dc0: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 (exit 1)))
3dd0: 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 69 6e 74 ..(define (print
3de0: 2d 70 6b 74 2d 6b 65 79 73 20 69 6e 6c 73 74 29 -pkt-keys inlst)
3df0: 0a 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 . (for-each.
3e00: 28 6c 61 6d 62 64 61 20 28 70 29 0a 20 20 20 20 (lambda (p).
3e10: 20 28 6c 65 74 20 28 28 73 77 20 28 63 61 72 20 (let ((sw (car
3e20: 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 p)). (
3e30: 63 20 20 28 63 64 72 20 70 29 29 29 0a 20 20 20 c (cdr p))).
3e40: 20 20 20 20 28 70 72 69 6e 74 20 28 6f 72 20 63 (print (or c
3e50: 20 22 6e 2f 61 22 29 20 22 5c 74 22 20 73 77 29 "n/a") "\t" sw)
3e60: 29 29 0a 20 20 20 69 6e 6c 73 74 29 29 0a 0a 28 )). inlst))..(
3e70: 64 65 66 69 6e 65 20 28 70 72 69 6e 74 2d 64 75 define (print-du
3e80: 70 6c 69 63 61 74 65 2d 6b 65 79 73 20 2e 20 61 plicate-keys . a
3e90: 6c 6c 29 0a 20 20 28 6c 65 74 20 28 28 63 61 72 ll). (let ((car
3ea0: 64 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 d-hash (make-has
3eb0: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
3ec0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
3ed0: 61 6d 62 64 61 20 28 6c 73 74 29 0a 20 20 20 20 ambda (lst).
3ee0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
3ef0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 63 61 (lambda (ca
3f00: 72 64 2d 73 70 65 63 29 0a 20 20 20 20 20 20 20 rd-spec).
3f10: 20 20 20 28 6c 65 74 20 28 28 6b 20 28 63 64 72 (let ((k (cdr
3f20: 20 63 61 72 64 2d 73 70 65 63 29 29 29 0a 20 20 card-spec))).
3f30: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
3f40: 69 6e 74 20 22 63 61 72 64 2d 73 70 65 63 3a 20 int "card-spec:
3f50: 22 20 63 61 72 64 2d 73 70 65 63 20 22 2c 20 6b " card-spec ", k
3f60: 3a 20 22 20 6b 29 0a 20 20 20 20 20 20 20 20 20 : " k).
3f70: 20 20 20 28 69 66 20 6b 20 28 68 61 73 68 2d 74 (if k (hash-t
3f80: 61 62 6c 65 2d 73 65 74 21 20 63 61 72 64 2d 68 able-set! card-h
3f90: 61 73 68 20 6b 20 28 2b 20 28 68 61 73 68 2d 74 ash k (+ (hash-t
3fa0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3fb0: 20 63 61 72 64 2d 68 61 73 68 20 6b 20 30 29 20 card-hash k 0)
3fc0: 31 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 6c 1))))). l
3fd0: 73 74 29 29 0a 20 20 20 20 20 61 6c 6c 29 0a 20 st)). all).
3fe0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
3ff0: 20 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 20 20 (lambda (k).
4000: 20 20 20 20 20 28 69 66 20 28 3e 20 28 68 61 73 (if (> (has
4010: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 72 64 h-table-ref card
4020: 2d 68 61 73 68 20 6b 29 20 31 29 0a 20 20 20 20 -hash k) 1).
4030: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 6b 20 (print k
4040: 22 5c 74 22 20 28 68 61 73 68 2d 74 61 62 6c 65 "\t" (hash-table
4050: 2d 72 65 66 20 63 61 72 64 2d 68 61 73 68 20 6b -ref card-hash k
4060: 29 29 29 29 0a 20 20 20 20 20 28 73 6f 72 74 20 )))). (sort
4070: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
4080: 20 63 61 72 64 2d 68 61 73 68 29 20 28 6c 61 6d card-hash) (lam
4090: 62 64 61 20 28 61 20 62 29 28 3e 3d 20 28 68 61 bda (a b)(>= (ha
40a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 61 72 sh-table-ref car
40b0: 64 2d 68 61 73 68 20 61 29 28 68 61 73 68 2d 74 d-hash a)(hash-t
40c0: 61 62 6c 65 2d 72 65 66 20 63 61 72 64 2d 68 61 able-ref card-ha
40d0: 73 68 20 62 29 29 29 29 29 0a 20 20 20 20 29 29 sh b))))). ))
40e0: 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 69 6e 74 ..(define (print
40f0: 2d 70 6b 74 2d 6b 65 79 2d 69 6e 66 6f 29 0a 20 -pkt-key-info).
4100: 20 28 70 72 69 6e 74 20 22 41 72 67 75 6d 65 6e (print "Argumen
4110: 74 20 6b 65 79 73 22 29 0a 20 20 28 70 72 69 6e t keys"). (prin
4120: 74 2d 70 6b 74 2d 6b 65 79 73 20 2a 61 72 67 2d t-pkt-keys *arg-
4130: 6b 65 79 73 2a 29 0a 20 20 28 70 72 69 6e 74 20 keys*). (print
4140: 22 5c 6e 53 77 69 74 63 68 20 6b 65 79 73 22 29 "\nSwitch keys")
4150: 0a 20 20 28 70 72 69 6e 74 2d 70 6b 74 2d 6b 65 . (print-pkt-ke
4160: 79 73 20 2a 73 77 69 74 63 68 2d 6b 65 79 73 2a ys *switch-keys*
4170: 29 0a 20 20 28 70 72 69 6e 74 20 22 5c 6e 41 63 ). (print "\nAc
4180: 74 69 6f 6e 20 6b 65 79 73 22 29 0a 20 20 28 70 tion keys"). (p
4190: 72 69 6e 74 2d 70 6b 74 2d 6b 65 79 73 20 2a 61 rint-pkt-keys *a
41a0: 63 74 69 6f 6e 2d 6b 65 79 73 2a 29 0a 20 20 28 ction-keys*). (
41b0: 70 72 69 6e 74 20 22 5c 6e 41 64 64 69 74 69 6f print "\nAdditio
41c0: 6e 61 6c 20 63 61 72 64 73 22 29 0a 20 20 28 70 nal cards"). (p
41d0: 72 69 6e 74 2d 70 6b 74 2d 6b 65 79 73 20 28 73 rint-pkt-keys (s
41e0: 77 69 7a 7a 6c 65 2d 61 6c 69 73 74 20 2a 61 64 wizzle-alist *ad
41f0: 64 69 74 69 6f 6e 61 6c 2d 63 61 72 64 73 2a 29 ditional-cards*)
4200: 29 0a 20 20 28 70 72 69 6e 74 20 22 5c 6e 44 75 ). (print "\nDu
4210: 70 6c 69 63 61 74 65 20 6b 65 79 73 22 29 0a 20 plicate keys").
4220: 20 28 70 72 69 6e 74 2d 64 75 70 6c 69 63 61 74 (print-duplicat
4230: 65 2d 6b 65 79 73 20 2a 61 72 67 2d 6b 65 79 73 e-keys *arg-keys
4240: 2a 20 2a 73 77 69 74 63 68 2d 6b 65 79 73 2a 20 * *switch-keys*
4250: 2a 61 63 74 69 6f 6e 2d 6b 65 79 73 2a 20 28 73 *action-keys* (s
4260: 77 69 7a 7a 6c 65 2d 61 6c 69 73 74 20 2a 61 64 wizzle-alist *ad
4270: 64 69 74 69 6f 6e 61 6c 2d 63 61 72 64 73 2a 29 ditional-cards*)
4280: 29 0a 20 20 28 70 72 69 6e 74 20 22 5c 6e 45 6e ). (print "\nEn
4290: 64 20 6f 66 20 72 65 70 6f 72 74 2e 22 29 0a 20 d of report.").
42a0: 20 29 0a 0a 3b 3b 20 6c 69 73 74 20 70 61 63 6b )..;; list pack
42b0: 65 74 20 6b 65 79 73 0a 3b 3b 0a 28 69 66 20 28 et keys.;;.(if (
42c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6c args:get-arg "-l
42d0: 69 73 74 2d 70 6b 74 2d 6b 65 79 73 22 29 0a 20 ist-pkt-keys").
42e0: 20 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e 74 (begin (print
42f0: 2d 70 6b 74 2d 6b 65 79 2d 69 6e 66 6f 29 28 65 -pkt-key-info)(e
4300: 78 69 74 20 30 29 29 29 0a 0a 3b 3b 20 28 70 72 xit 0)))..;; (pr
4310: 69 6e 74 20 22 2a 61 63 74 69 6f 6e 2a 3a 20 22 int "*action*: "
4320: 20 2a 61 63 74 69 6f 6e 2a 29 0a 0a 3b 3b 20 28 *action*)..;; (
4330: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 75 75 let-values (((uu
4340: 69 64 20 70 6b 74 29 0a 3b 3b 20 09 20 20 20 20 id pkt).;; .
4350: 20 20 28 63 6f 6d 6d 61 6e 64 2d 6c 69 6e 65 2d (command-line-
4360: 3e 70 6b 74 20 23 66 20 61 72 67 73 3a 61 72 67 >pkt #f args:arg
4370: 2d 68 61 73 68 29 29 29 0a 3b 3b 20 20 20 28 70 -hash))).;; (p
4380: 72 69 6e 74 20 70 6b 74 29 29 0a 0a 3b 3b 20 41 rint pkt))..;; A
4390: 64 64 20 61 72 67 73 20 74 68 61 74 20 75 73 65 dd args that use
43a0: 20 72 65 6d 61 72 67 73 20 68 65 72 65 0a 3b 3b remargs here.;;
43b0: 0a 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 .(if (and (not (
43c0: 6e 75 6c 6c 3f 20 72 65 6d 61 72 67 73 29 29 0a null? remargs)).
43d0: 09 20 28 6e 6f 74 20 28 6f 72 0a 09 20 20 20 20 . (not (or..
43e0: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
43f0: 20 22 2d 72 75 6e 73 74 65 70 22 29 0a 09 20 20 "-runstep")..
4400: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
4410: 72 67 20 22 2d 65 6e 76 63 61 70 22 29 0a 09 20 rg "-envcap")..
4420: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
4430: 61 72 67 20 22 2d 65 6e 76 64 65 6c 74 61 22 29 arg "-envdelta")
4440: 0a 09 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 .. (member
4450: 20 2a 61 63 74 69 6f 6e 2a 20 27 28 22 64 62 22 *action* '("db"
4460: 20 22 74 73 65 6e 64 22 20 22 74 6c 69 73 74 65 "tsend" "tliste
4470: 6e 22 29 29 20 20 20 3b 3b 20 76 65 72 79 20 6c n")) ;; very l
4480: 6f 6f 73 65 20 63 68 65 63 6b 73 20 6f 6e 20 64 oose checks on d
4490: 62 20 61 6e 64 20 74 73 65 6e 64 2f 6c 69 73 74 b and tsend/list
44a0: 65 6e 0a 09 20 20 20 20 20 20 20 28 65 71 75 61 en.. (equa
44b0: 6c 3f 20 2a 61 63 74 69 6f 6e 2a 20 22 73 68 6f l? *action* "sho
44c0: 77 22 29 20 20 20 20 3b 3b 20 6a 75 73 74 20 6b w") ;; just k
44d0: 65 65 70 20 67 6f 69 6e 67 20 69 66 20 6c 69 73 eep going if lis
44e0: 74 0a 09 20 20 20 20 20 20 20 29 29 29 0a 20 20 t.. ))).
44f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
4500: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
4510: 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 72 65 63 log-port* "Unrec
4520: 6f 67 6e 69 73 65 64 20 61 72 67 75 6d 65 6e 74 ognised argument
4530: 73 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 s: " (string-int
4540: 65 72 73 70 65 72 73 65 20 28 69 66 20 28 6c 69 ersperse (if (li
4550: 73 74 3f 20 72 65 6d 61 72 67 73 29 20 72 65 6d st? remargs) rem
4560: 61 72 67 73 20 28 61 72 67 76 29 29 20 20 22 20 args (argv)) "
4570: 22 29 29 29 0a 0a 28 69 66 20 28 6f 72 20 28 61 ")))..(if (or (a
4580: 72 67 73 3a 61 6e 79 3f 20 22 2d 68 22 20 22 68 rgs:any? "-h" "h
4590: 65 6c 70 22 20 22 2d 68 65 6c 70 22 20 22 2d 2d elp" "-help" "--
45a0: 68 65 6c 70 22 29 0a 09 28 6d 65 6d 62 65 72 20 help")..(member
45b0: 2a 61 63 74 69 6f 6e 2a 20 27 28 22 2d 68 22 20 *action* '("-h"
45c0: 22 2d 68 65 6c 70 22 20 22 2d 2d 68 65 6c 70 22 "-help" "--help"
45d0: 20 22 68 65 6c 70 22 29 29 29 0a 20 20 20 20 28 "help"))). (
45e0: 62 65 67 69 6e 0a 20 20 20 20 20 20 28 70 72 69 begin. (pri
45f0: 6e 74 20 68 65 6c 70 29 0a 20 20 20 20 20 20 28 nt help). (
4600: 65 78 69 74 20 31 29 29 29 0a 0a 3b 3b 3d 3d 3d exit 1)))..;;===
4610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4650: 3d 3d 3d 0a 3b 3b 20 4e 61 6e 6f 6d 73 67 20 74 ===.;; Nanomsg t
4660: 72 61 6e 73 70 6f 72 74 0a 3b 3b 3d 3d 3d 3d 3d ransport.;;=====
4670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
46a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
46b0: 3d 0a 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e =..(define-inlin
46c0: 65 20 28 65 6e 63 6f 64 65 20 64 61 74 61 29 0a e (encode data).
46d0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
46e0: 6f 2d 73 74 72 69 6e 67 0a 20 20 20 20 28 6c 61 o-string. (la
46f0: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 28 77 mbda (). (w
4700: 72 69 74 65 20 64 61 74 61 29 29 29 29 0a 0a 28 rite data))))..(
4710: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 64 define-inline (d
4720: 65 63 6f 64 65 20 64 61 74 61 29 0a 20 20 28 77 ecode data). (w
4730: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 ith-input-from-s
4740: 74 72 69 6e 67 0a 20 20 20 20 20 20 64 61 74 61 tring. data
4750: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
4760: 20 20 20 20 20 20 28 72 65 61 64 29 29 29 29 0a (read)))).
4770: 0a 28 64 65 66 69 6e 65 20 28 69 73 2d 70 6f 72 .(define (is-por
4780: 74 2d 69 6e 2d 75 73 65 20 70 6f 72 74 2d 6e 75 t-in-use port-nu
4790: 6d 29 0a 20 28 6c 65 74 2a 20 28 28 72 65 74 20 m). (let* ((ret
47a0: 23 66 29 29 0a 20 20 20 20 20 28 6c 65 74 2d 76 #f)). (let-v
47b0: 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f 75 70 alues (((inp oup
47c0: 20 70 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 pid).
47d0: 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 20 22 (process "
47e0: 6e 65 74 73 74 61 74 22 20 28 6c 69 73 74 20 20 netstat" (list
47f0: 22 2d 74 75 6c 70 6e 22 20 29 29 29 29 0a 20 20 "-tulpn" )))).
4800: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
4810: 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 20 69 inl (read-line i
4820: 6e 70 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 np))). (i
4830: 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 f (not (eof-obje
4840: 63 74 3f 20 69 6e 6c 29 29 0a 20 20 20 20 20 20 ct? inl)).
4850: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
4860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
4870: 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
4880: 20 28 72 65 67 65 78 70 20 28 63 6f 6e 63 20 22 (regexp (conc "
4890: 3a 22 20 70 6f 72 74 2d 6e 75 6d 29 29 20 69 6e :" port-num)) in
48a0: 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 l).
48b0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
48c0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 28 70 72 ;(pr
48d0: 69 6e 74 20 22 4f 75 74 70 75 74 3a 20 22 20 20 int "Output: "
48e0: 69 6e 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 inl).
48f0: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 74 (set! ret
4900: 20 20 23 74 29 29 0a 20 20 20 20 20 20 20 20 20 #t)).
4910: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 (loop (r
4920: 65 61 64 2d 6c 69 6e 65 20 69 6e 70 29 29 29 29 ead-line inp))))
4930: 29 29 29 0a 72 65 74 29 29 0a 0a 3b 3b 73 74 61 ))).ret))..;;sta
4940: 72 74 20 61 20 73 65 72 76 65 72 2c 20 72 65 74 rt a server, ret
4950: 75 72 6e 73 20 74 68 65 20 63 6f 6e 6e 65 63 74 urns the connect
4960: 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ion.;;.(define (
4970: 73 74 61 72 74 2d 6e 6e 2d 73 65 72 76 65 72 20 start-nn-server
4980: 70 6f 72 74 6e 75 6d 20 29 0a 20 20 28 6c 65 74 portnum ). (let
4990: 20 28 28 72 65 70 20 28 6e 6e 2d 73 6f 63 6b 65 ((rep (nn-socke
49a0: 74 20 27 72 65 70 29 29 29 0a 20 20 20 20 28 68 t 'rep))). (h
49b0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
49c0: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 . exn. (
49d0: 6c 65 74 20 28 28 65 6d 73 67 20 28 28 63 6f 6e let ((emsg ((con
49e0: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
49f0: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
4a00: 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 0a 20 essage) exn))).
4a10: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 (print "ER
4a20: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 73 ROR: Failed to s
4a30: 74 61 72 74 20 73 65 72 76 65 72 20 5c 22 22 20 tart server \""
4a40: 65 6d 73 67 20 22 5c 22 22 29 0a 20 20 20 20 20 emsg "\"").
4a50: 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 (exit 1)).
4a60: 20 20 0a 20 20 20 20 20 28 6e 6e 2d 62 69 6e 64 . (nn-bind
4a70: 20 72 65 70 20 28 63 6f 6e 63 20 22 74 63 70 3a rep (conc "tcp:
4a80: 2f 2f 2a 3a 22 20 70 6f 72 74 6e 75 6d 29 29 29 //*:" portnum)))
4a90: 0a 20 20 20 20 72 65 70 29 29 0a 0a 28 64 65 66 . rep))..(def
4aa0: 69 6e 65 20 28 63 61 6e 2d 75 73 65 72 2d 6b 69 ine (can-user-ki
4ab0: 6c 6c 2d 6c 69 73 74 6e 65 72 20 75 73 65 72 2d ll-listner user-
4ac0: 69 6e 66 6f 20 61 74 74 72 69 62 29 0a 20 20 28 info attrib). (
4ad0: 6c 65 74 2a 20 28 28 63 6f 6e 74 61 63 74 73 20 let* ((contacts
4ae0: 28 61 6c 69 73 74 2d 72 65 66 20 27 63 6f 6e 74 (alist-ref 'cont
4af0: 61 63 74 20 61 74 74 72 69 62 29 29 0a 20 20 20 act attrib)).
4b00: 20 20 20 20 20 20 28 75 73 65 72 2d 69 64 20 28 (user-id (
4b10: 63 61 64 64 64 72 20 28 63 64 72 20 75 73 65 72 cadddr (cdr user
4b20: 2d 69 6e 66 6f 29 29 29 0a 20 20 20 20 20 20 20 -info))).
4b30: 20 20 28 72 65 74 20 23 66 29 20 20 0a 20 20 20 (ret #f) .
4b40: 20 20 20 20 20 20 28 63 6f 6e 74 61 63 74 2d 6c (contact-l
4b50: 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ist (string-spli
4b60: 74 20 63 6f 6e 74 61 63 74 73 20 22 2c 22 29 29 t contacts ","))
4b70: 29 20 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ) . (for-each
4b80: 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
4b90: 61 64 6d 69 6e 29 0a 20 20 20 20 20 20 20 20 28 admin). (
4ba0: 69 66 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 if (string-conta
4bb0: 69 6e 73 20 20 75 73 65 72 2d 69 64 20 28 63 61 ins user-id (ca
4bc0: 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
4bd0: 61 64 6d 69 6e 20 22 40 22 29 29 29 0a 20 20 20 admin "@"))).
4be0: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 74 20 (set! ret
4bf0: 23 74 29 29 29 20 20 0a 20 20 20 20 63 6f 6e 74 #t))) . cont
4c00: 61 63 74 2d 6c 69 73 74 29 0a 20 20 20 72 65 74 act-list). ret
4c10: 29 29 0a 0a 3b 3b 20 6f 70 65 6e 20 63 6f 6e 6e ))..;; open conn
4c20: 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 76 65 72 ection to server
4c30: 2c 20 73 65 6e 64 20 6d 65 73 73 61 67 65 2c 20 , send message,
4c40: 63 6c 6f 73 65 20 63 6f 6e 6e 65 63 74 69 6f 6e close connection
4c50: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6f 70 65 .;;.(define (ope
4c60: 6e 2d 73 65 6e 64 2d 63 6c 6f 73 65 2d 6e 6e 20 n-send-close-nn
4c70: 68 6f 73 74 2d 70 6f 72 74 20 6d 73 67 20 61 74 host-port msg at
4c80: 74 72 69 62 20 23 21 6b 65 79 20 28 74 69 6d 65 trib #!key (time
4c90: 6f 75 74 20 33 29 20 29 20 3b 3b 20 64 65 66 61 out 3) ) ;; defa
4ca0: 75 6c 74 20 74 69 6d 65 6f 75 74 20 69 73 20 33 ult timeout is 3
4cb0: 20 73 65 63 6f 6e 64 73 0a 20 20 28 6c 65 74 20 seconds. (let
4cc0: 28 28 72 65 71 20 20 28 6e 6e 2d 73 6f 63 6b 65 ((req (nn-socke
4cd0: 74 20 27 72 65 71 29 29 0a 20 20 20 20 20 20 20 t 'req)).
4ce0: 20 28 75 72 69 20 20 28 63 6f 6e 63 20 22 74 63 (uri (conc "tc
4cf0: 70 3a 2f 2f 22 20 68 6f 73 74 2d 70 6f 72 74 29 p://" host-port)
4d00: 29 0a 20 20 20 20 20 20 20 20 28 72 65 73 20 20 ). (res
4d10: 23 66 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e #f). (con
4d20: 74 61 63 74 73 20 28 61 6c 69 73 74 2d 72 65 66 tacts (alist-ref
4d30: 20 27 63 6f 6e 74 61 63 74 20 61 74 74 72 69 62 'contact attrib
4d40: 29 29 0a 20 20 20 20 20 20 20 20 28 6d 6f 64 65 )). (mode
4d50: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 6d 6f 64 (alist-ref 'mod
4d60: 65 20 61 74 74 72 69 62 29 29 29 20 0a 20 20 20 e attrib))) .
4d70: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
4d80: 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
4d90: 20 20 28 6c 65 74 20 28 28 65 6d 73 67 20 28 28 (let ((emsg ((
4da0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
4db0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
4dc0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
4dd0: 29 0a 20 20 20 20 20 20 20 3b 3b 20 53 65 6e 64 ). ;; Send
4de0: 20 6e 6f 74 69 66 69 63 61 74 69 6f 6e 20 20 20 notification
4df0: 20 20 20 20 0a 20 20 20 20 20 20 20 28 70 72 69 . (pri
4e00: 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 nt "ERROR: Faile
4e10: 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 2f 20 73 d to connect / s
4e20: 65 6e 64 20 74 6f 20 22 20 75 72 69 20 22 20 6d end to " uri " m
4e30: 65 73 73 61 67 65 20 77 61 73 20 5c 22 22 20 65 essage was \"" e
4e40: 6d 73 67 20 22 5c 22 22 20 29 0a 20 20 20 20 20 msg "\"" ).
4e50: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
4e60: 6d 6f 64 65 20 22 70 72 6f 64 75 63 74 69 6f 6e mode "production
4e70: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
4e80: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
4e90: 20 20 20 20 20 28 70 72 69 6e 74 20 22 20 53 65 (print " Se
4ea0: 6e 64 69 6e 67 20 65 6d 61 69 6c 20 74 6f 20 63 nding email to c
4eb0: 6f 6e 74 61 63 74 73 20 3a 20 22 20 63 6f 6e 74 ontacts : " cont
4ec0: 61 63 74 73 20 29 0a 20 20 20 20 20 20 20 20 20 acts ).
4ed0: 20 20 20 20 28 6c 65 74 20 28 28 65 6d 61 69 6c (let ((email
4ee0: 2d 62 6f 64 79 20 28 6d 74 75 74 3a 73 74 6d 6c -body (mtut:stml
4ef0: 2d 3e 73 74 72 69 6e 67 20 28 73 3a 62 6f 64 79 ->string (s:body
4f00: 0a 09 09 09 09 09 09 09 09 09 09 28 73 3a 70 20 ...........(s:p
4f10: 28 63 6f 6e 63 20 22 57 65 20 63 6f 75 6c 64 20 (conc "We could
4f20: 6e 6f 74 20 73 65 6e 64 20 6d 65 73 73 61 67 65 not send message
4f30: 73 20 74 6f 20 74 68 65 20 73 65 72 76 65 72 20 s to the server
4f40: 6f 6e 20 22 20 75 72 69 20 22 2e 22 20 20 22 50 on " uri "." "P
4f50: 6c 65 61 73 65 20 63 68 65 63 6b 20 69 66 20 74 lease check if t
4f60: 68 65 20 6c 69 73 74 6e 65 72 20 69 73 20 72 75 he listner is ru
4f70: 6e 6e 69 6e 67 2e 20 49 74 20 69 73 20 70 6f 73 nning. It is pos
4f80: 73 69 62 6c 65 20 74 68 61 74 20 74 68 65 20 68 sible that the h
4f90: 6f 73 74 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 ost is overloade
4fa0: 64 20 64 75 65 20 74 6f 20 77 68 69 63 68 20 69 d due to which i
4fb0: 74 20 6d 61 79 20 74 61 6b 65 20 74 6f 6f 20 6c t may take too l
4fc0: 6f 6e 67 20 74 6f 20 72 65 73 70 6f 6e 64 2e 20 ong to respond.
4fd0: 5c 6e 20 43 6f 6e 74 61 63 74 20 79 6f 75 72 20 \n Contact your
4fe0: 73 79 73 74 65 6d 20 61 64 6d 69 6e 73 74 72 61 system adminstra
4ff0: 74 6f 72 20 69 66 20 73 65 72 76 65 72 20 6c 6f tor if server lo
5000: 61 64 20 69 73 20 68 69 67 68 2e 22 20 28 73 3a ad is high." (s:
5010: 62 72 29 22 20 54 68 61 6e 6b 20 59 6f 75 20 22 br)" Thank You "
5020: 29 20 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ) ))))).
5030: 20 20 20 20 20 28 73 65 6e 64 6d 61 69 6c 20 28 (sendmail (
5040: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 73 74 72 string-join (str
5050: 69 6e 67 2d 73 70 6c 69 74 20 63 6f 6e 74 61 63 ing-split contac
5060: 74 73 20 22 3b 22 20 29 29 20 28 63 6f 6e 63 20 ts ";" )) (conc
5070: 22 5b 4c 69 73 74 6e 65 72 20 45 72 72 6f 72 5d "[Listner Error]
5080: 20 46 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 Filed to connec
5090: 74 20 74 6f 20 6c 69 73 74 6e 65 72 20 6f 6e 20 t to listner on
50a0: 22 20 75 72 69 29 20 65 6d 61 69 6c 2d 62 6f 64 " uri) email-bod
50b0: 79 20 20 75 73 65 5f 68 74 6d 6c 3a 20 23 74 29 y use_html: #t)
50c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
50d0: 28 70 72 69 6e 74 20 22 20 6d 6f 64 65 20 3a 20 (print " mode :
50e0: 22 20 6d 6f 64 65 20 22 20 4e 6f 74 20 73 65 6e " mode " Not sen
50f0: 64 69 6e 67 20 61 6e 79 20 65 6d 61 69 6c 73 22 ding any emails"
5100: 20 29 29 0a 20 20 20 20 20 20 20 23 66 29 0a 20 )). #f).
5110: 20 20 20 20 28 6e 6e 2d 63 6f 6e 6e 65 63 74 20 (nn-connect
5120: 72 65 71 20 75 72 69 29 0a 20 20 20 20 20 28 70 req uri). (p
5130: 72 69 6e 74 20 22 43 6f 6e 6e 65 63 74 65 64 20 rint "Connected
5140: 74 6f 20 74 68 65 20 73 65 72 76 65 72 20 22 20 to the server "
5150: 29 0a 20 20 20 20 20 28 6e 6e 2d 73 65 6e 64 20 ). (nn-send
5160: 72 65 71 20 6d 73 67 29 0a 20 20 20 20 20 28 70 req msg). (p
5170: 72 69 6e 74 20 22 52 65 71 75 65 73 74 20 53 65 rint "Request Se
5180: 6e 74 22 29 20 20 0a 20 20 20 20 20 28 6c 65 74 nt") . (let
5190: 2a 20 28 28 74 68 31 20 20 28 6d 61 6b 65 2d 74 * ((th1 (make-t
51a0: 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 hread (lambda ()
51b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
51c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51d0: 20 20 28 6c 65 74 20 28 28 72 65 73 70 20 28 6e (let ((resp (n
51e0: 6e 2d 72 65 63 76 20 72 65 71 29 29 29 0a 20 20 n-recv req))).
51f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5210: 20 28 6e 6e 2d 63 6c 6f 73 65 20 72 65 71 29 0a (nn-close req).
5220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5240: 20 20 20 28 73 65 74 21 20 72 65 73 20 28 69 66 (set! res (if
5250: 20 28 65 71 75 61 6c 3f 20 72 65 73 70 20 22 6f (equal? resp "o
5260: 6b 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 k").
5270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5290: 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 #t.
52a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52c0: 20 20 20 20 20 20 20 20 20 23 66 29 29 29 29 0a #f)))).
52d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
52f0: 72 65 63 76 20 74 68 72 65 61 64 22 29 29 0a 20 recv thread")).
5300: 20 20 20 20 20 20 20 20 20 20 20 28 74 68 32 20 (th2
5310: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
5320: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 mbda ().
5330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5340: 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d (thread-
5350: 73 6c 65 65 70 21 20 74 69 6d 65 6f 75 74 29 0a sleep! timeout).
5360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5380: 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 (thread-terminat
5390: 65 21 20 74 68 31 29 29 0a 20 20 20 20 20 20 20 e! th1)).
53a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53b0: 20 20 20 20 20 20 22 74 69 6d 65 72 20 74 68 72 "timer thr
53c0: 65 61 64 22 29 29 29 0a 20 20 20 20 20 20 20 28 ead"))). (
53d0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
53e0: 31 29 0a 20 20 20 20 20 20 20 28 74 68 72 65 61 1). (threa
53f0: 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 d-start! th2).
5400: 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 (thread-joi
5410: 6e 21 20 74 68 31 29 0a 20 20 20 20 20 20 20 72 n! th1). r
5420: 65 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 es))))..(define
5430: 28 6f 70 65 6e 2d 73 65 6e 64 2d 72 65 63 65 69 (open-send-recei
5440: 76 65 2d 6e 6e 20 68 6f 73 74 2d 70 6f 72 74 20 ve-nn host-port
5450: 6d 73 67 20 61 74 74 72 69 62 20 23 21 6b 65 79 msg attrib #!key
5460: 20 28 74 69 6d 65 6f 75 74 20 33 29 20 29 20 3b (timeout 3) ) ;
5470: 3b 20 64 65 66 61 75 6c 74 20 74 69 6d 65 6f 75 ; default timeou
5480: 74 20 69 73 20 33 20 73 65 63 6f 6e 64 73 0a 20 t is 3 seconds.
5490: 20 28 6c 65 74 20 28 28 72 65 71 20 20 28 6e 6e (let ((req (nn
54a0: 2d 73 6f 63 6b 65 74 20 27 72 65 71 29 29 0a 20 -socket 'req)).
54b0: 20 20 20 20 20 20 20 28 75 72 69 20 20 28 63 6f (uri (co
54c0: 6e 63 20 22 74 63 70 3a 2f 2f 22 20 68 6f 73 74 nc "tcp://" host
54d0: 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 20 20 20 -port)).
54e0: 28 72 65 73 20 20 23 66 29 0a 20 20 20 20 20 20 (res #f).
54f0: 20 20 28 63 6f 6e 74 61 63 74 73 20 28 61 6c 69 (contacts (ali
5500: 73 74 2d 72 65 66 20 27 63 6f 6e 74 61 63 74 20 st-ref 'contact
5510: 61 74 74 72 69 62 29 29 0a 20 20 20 20 20 20 20 attrib)).
5520: 20 28 6d 6f 64 65 20 28 61 6c 69 73 74 2d 72 65 (mode (alist-re
5530: 66 20 27 6d 6f 64 65 20 61 74 74 72 69 62 29 29 f 'mode attrib))
5540: 29 20 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ) . (handle-e
5550: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 xceptions. e
5560: 78 6e 0a 20 20 20 20 20 28 6c 65 74 20 28 28 65 xn. (let ((e
5570: 6d 73 67 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d msg ((condition-
5580: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
5590: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
55a0: 20 65 78 6e 29 29 29 0a 20 20 20 20 20 20 20 3b exn))). ;
55b0: 3b 20 53 65 6e 64 20 6e 6f 74 69 66 69 63 61 74 ; Send notificat
55c0: 69 6f 6e 20 20 20 20 20 20 0a 20 20 20 20 20 20 ion .
55d0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
55e0: 46 61 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 Failed to connec
55f0: 74 20 2f 20 73 65 6e 64 20 74 6f 20 22 20 75 72 t / send to " ur
5600: 69 20 22 20 6d 65 73 73 61 67 65 20 77 61 73 20 i " message was
5610: 5c 22 22 20 65 6d 73 67 20 22 5c 22 22 20 29 0a \"" emsg "\"" ).
5620: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 65 71 (if (eq
5630: 75 61 6c 3f 20 6d 6f 64 65 20 22 70 72 6f 64 75 ual? mode "produ
5640: 63 74 69 6f 6e 22 29 0a 20 20 20 20 20 20 20 20 ction").
5650: 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 (begin .
5660: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
5670: 20 22 20 53 65 6e 64 69 6e 67 20 65 6d 61 69 6c " Sending email
5680: 20 74 6f 20 63 6f 6e 74 61 63 74 73 20 3a 20 22 to contacts : "
5690: 20 63 6f 6e 74 61 63 74 73 20 29 0a 20 20 20 20 contacts ).
56a0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
56b0: 65 6d 61 69 6c 2d 62 6f 64 79 20 28 6d 74 75 74 email-body (mtut
56c0: 3a 73 74 6d 6c 2d 3e 73 74 72 69 6e 67 20 28 73 :stml->string (s
56d0: 3a 62 6f 64 79 0a 09 09 09 09 09 09 09 09 09 09 :body...........
56e0: 28 73 3a 70 20 28 63 6f 6e 63 20 22 57 65 20 63 (s:p (conc "We c
56f0: 6f 75 6c 64 20 6e 6f 74 20 73 65 6e 64 20 6d 65 ould not send me
5700: 73 73 61 67 65 73 20 74 6f 20 74 68 65 20 73 65 ssages to the se
5710: 72 76 65 72 20 6f 6e 20 22 20 75 72 69 20 22 2e rver on " uri ".
5720: 22 20 20 22 50 6c 65 61 73 65 20 63 68 65 63 6b " "Please check
5730: 20 69 66 20 74 68 65 20 6c 69 73 74 6e 65 72 20 if the listner
5740: 69 73 20 72 75 6e 6e 69 6e 67 2e 20 49 74 20 69 is running. It i
5750: 73 20 70 6f 73 73 69 62 6c 65 20 74 68 61 74 20 s possible that
5760: 74 68 65 20 68 6f 73 74 20 69 73 20 6f 76 65 72 the host is over
5770: 6c 6f 61 64 65 64 20 64 75 65 20 74 6f 20 77 68 loaded due to wh
5780: 69 63 68 20 69 74 20 6d 61 79 20 74 61 6b 65 20 ich it may take
5790: 74 6f 6f 20 6c 6f 6e 67 20 74 6f 20 72 65 73 70 too long to resp
57a0: 6f 6e 64 2e 20 5c 6e 20 43 6f 6e 74 61 63 74 20 ond. \n Contact
57b0: 79 6f 75 72 20 73 79 73 74 65 6d 20 61 64 6d 69 your system admi
57c0: 6e 73 74 72 61 74 6f 72 20 69 66 20 73 65 72 76 nstrator if serv
57d0: 65 72 20 6c 6f 61 64 20 69 73 20 68 69 67 68 2e er load is high.
57e0: 22 20 28 73 3a 62 72 29 22 20 54 68 61 6e 6b 20 " (s:br)" Thank
57f0: 59 6f 75 20 22 29 20 29 29 29 29 29 0a 20 20 20 You ") ))))).
5800: 20 20 20 20 20 20 20 20 20 20 28 73 65 6e 64 6d (sendm
5810: 61 69 6c 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e ail (string-join
5820: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 (string-split c
5830: 6f 6e 74 61 63 74 73 20 22 3b 22 20 29 29 20 28 ontacts ";" )) (
5840: 63 6f 6e 63 20 22 5b 4c 69 73 74 6e 65 72 20 45 conc "[Listner E
5850: 72 72 6f 72 5d 20 46 69 6c 65 64 20 74 6f 20 63 rror] Filed to c
5860: 6f 6e 6e 65 63 74 20 74 6f 20 6c 69 73 74 6e 65 onnect to listne
5870: 72 20 6f 6e 20 22 20 75 72 69 29 20 65 6d 61 69 r on " uri) emai
5880: 6c 2d 62 6f 64 79 20 20 75 73 65 5f 68 74 6d 6c l-body use_html
5890: 3a 20 23 74 29 29 29 0a 20 20 20 20 20 20 20 20 : #t))).
58a0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 20 6d 6f (print " mo
58b0: 64 65 20 3a 20 22 20 6d 6f 64 65 20 22 20 4e 6f de : " mode " No
58c0: 74 20 73 65 6e 64 69 6e 67 20 61 6e 79 20 65 6d t sending any em
58d0: 61 69 6c 73 22 20 29 29 0a 20 20 20 20 20 20 20 ails" )).
58e0: 23 66 29 0a 20 20 20 20 20 28 6e 6e 2d 63 6f 6e #f). (nn-con
58f0: 6e 65 63 74 20 72 65 71 20 75 72 69 29 0a 20 20 nect req uri).
5900: 20 20 20 28 70 72 69 6e 74 20 22 43 6f 6e 6e 65 (print "Conne
5910: 63 74 65 64 20 74 6f 20 74 68 65 20 73 65 72 76 cted to the serv
5920: 65 72 20 22 20 29 0a 20 20 20 20 20 28 6e 6e 2d er " ). (nn-
5930: 73 65 6e 64 20 72 65 71 20 6d 73 67 29 0a 20 20 send req msg).
5940: 20 20 20 28 70 72 69 6e 74 20 22 52 65 71 75 65 (print "Reque
5950: 73 74 20 53 65 6e 74 22 29 20 20 0a 20 20 20 20 st Sent") .
5960: 20 3b 3b 20 72 65 63 65 69 76 65 20 63 6f 64 65 ;; receive code
5970: 20 68 65 72 65 0a 20 20 20 20 20 3b 3b 28 70 72 here. ;;(pr
5980: 69 6e 74 20 28 6e 6e 2d 72 65 63 76 20 72 65 71 int (nn-recv req
5990: 29 29 0a 20 20 20 20 20 28 6c 65 74 2a 20 28 28 )). (let* ((
59a0: 74 68 31 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 th1 (make-threa
59b0: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 d (lambda ().
59c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
59e0: 65 74 20 28 28 72 65 73 70 20 28 6e 6e 2d 72 65 et ((resp (nn-re
59f0: 63 76 20 72 65 71 29 29 29 0a 20 20 20 20 20 20 cv req))).
5a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6e (nn
5a20: 2d 63 6c 6f 73 65 20 72 65 71 29 0a 20 20 20 20 -close req).
5a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5a50: 70 72 69 6e 74 20 72 65 73 70 29 0a 20 20 20 20 print resp).
5a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5a80: 73 65 74 21 20 72 65 73 20 28 69 66 20 28 65 71 set! res (if (eq
5a90: 75 61 6c 3f 20 72 65 73 70 20 22 6f 6b 22 29 0a ual? resp "ok").
5aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ad0: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t.
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 23 66 29 29 29 29 0a 20 20 20 20 #f)))).
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b20: 20 20 20 20 20 20 20 20 20 20 20 22 72 65 63 76 "recv
5b30: 20 74 68 72 65 61 64 22 29 29 0a 20 20 20 20 20 thread")).
5b40: 20 20 20 20 20 20 20 28 74 68 32 20 28 6d 61 6b (th2 (mak
5b50: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
5b60: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ().
5b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b80: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
5b90: 70 21 20 74 69 6d 65 6f 75 74 29 0a 20 20 20 20 p! timeout).
5ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 (thr
5bc0: 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 74 ead-terminate! t
5bd0: 68 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h1)).
5be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bf0: 20 20 22 74 69 6d 65 72 20 74 68 72 65 61 64 22 "timer thread"
5c00: 29 29 29 0a 20 20 20 20 20 20 20 28 74 68 72 65 ))). (thre
5c10: 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 ad-start! th1).
5c20: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
5c30: 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 20 art! th2).
5c40: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
5c50: 68 31 29 0a 20 20 20 20 20 20 20 72 65 73 29 29 h1). res))
5c60: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
5c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
5cb0: 52 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d Runs.;;=========
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 3d 3d 3d 3d 3d ================
5ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
5d00: 3b 20 6d 61 6b 65 20 61 20 72 75 6e 6e 61 6d 65 ; make a runname
5d10: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b .;;.(define (mak
5d20: 65 2d 72 75 6e 6e 61 6d 65 20 70 72 65 20 70 6f e-runname pre po
5d30: 73 74 29 0a 20 28 74 69 6d 65 2d 3e 73 74 72 69 st). (time->stri
5d40: 6e 67 0a 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c ng. (seconds->l
5d50: 6f 63 61 6c 2d 74 69 6d 65 20 28 63 75 72 72 65 ocal-time (curre
5d60: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 22 25 59 nt-seconds)) "%Y
5d70: 77 25 56 2e 25 77 2d 25 48 25 4d 22 29 29 0a 0a w%V.%w-%H%M"))..
5d80: 3b 3b 20 63 6f 6c 6c 65 63 74 2c 20 74 72 61 6e ;; collect, tran
5d90: 73 6c 61 74 65 2c 20 63 6f 6c 6c 61 74 65 20 61 slate, collate a
5da0: 6e 64 20 61 73 73 65 6d 62 6c 65 20 61 20 70 6b nd assemble a pk
5db0: 74 20 66 72 6f 6d 20 74 68 65 20 63 6f 6d 6d 61 t from the comma
5dc0: 6e 64 2d 6c 69 6e 65 0a 3b 3b 0a 3b 3b 20 73 63 nd-line.;;.;; sc
5dd0: 68 65 64 20 3d 3e 20 66 6f 72 63 65 20 74 68 65 hed => force the
5de0: 20 72 75 6e 20 73 74 61 72 74 20 74 69 6d 65 20 run start time
5df0: 74 6f 20 62 65 20 72 65 63 6f 72 64 65 64 20 61 to be recorded a
5e00: 73 20 73 63 68 65 64 20 55 6e 69 78 0a 3b 3b 20 s sched Unix.;;
5e10: 65 70 6f 63 68 2e 20 54 68 69 73 20 61 6c 69 67 epoch. This alig
5e20: 6e 73 20 74 69 6d 65 73 20 70 72 6f 70 65 72 6c ns times properl
5e30: 79 20 66 6f 72 20 74 72 69 67 67 65 72 73 20 69 y for triggers i
5e40: 6e 20 73 6f 6d 65 20 63 61 73 65 73 2e 0a 3b 3b n some cases..;;
5e50: 0a 3b 3b 20 20 65 78 74 72 61 2d 64 61 74 20 66 .;; extra-dat f
5e60: 6f 72 6d 61 74 20 69 73 20 28 20 27 78 20 78 76 ormat is ( 'x xv
5e70: 61 6c 20 27 79 20 79 76 61 6c 20 2e 2e 2e 2e 20 al 'y yval ....
5e80: 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ).;;.(define (co
5e90: 6d 6d 61 6e 64 2d 6c 69 6e 65 2d 3e 70 6b 74 20 mmand-line->pkt
5ea0: 61 63 74 69 6f 6e 20 61 72 67 73 2d 61 6c 69 73 action args-alis
5eb0: 74 20 73 63 68 65 64 2d 69 6e 20 23 21 6b 65 79 t sched-in #!key
5ec0: 20 28 65 78 74 72 61 2d 64 61 74 20 27 28 29 29 (extra-dat '())
5ed0: 28 61 72 65 61 2d 70 61 74 68 20 23 66 29 28 6e (area-path #f)(n
5ee0: 65 77 2d 73 73 20 23 66 29 29 0a 20 20 20 28 6c ew-ss #f)). (l
5ef0: 65 74 2a 20 28 28 73 63 68 65 64 20 20 20 20 20 et* ((sched
5f00: 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 28 76 (cond... ((v
5f10: 65 63 74 6f 72 3f 20 73 63 68 65 64 2d 69 6e 29 ector? sched-in)
5f20: 28 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e 73 65 63 (local-time->sec
5f30: 6f 6e 64 73 20 73 63 68 65 64 2d 69 6e 29 29 20 onds sched-in))
5f40: 3b 3b 20 77 65 20 72 65 63 69 65 76 65 64 20 61 ;; we recieved a
5f50: 20 74 69 6d 65 0a 09 09 20 20 20 20 20 28 28 6e time... ((n
5f60: 75 6d 62 65 72 3f 20 73 63 68 65 64 2d 69 6e 29 umber? sched-in)
5f70: 20 73 63 68 65 64 2d 69 6e 29 0a 09 09 20 20 20 sched-in)...
5f80: 20 20 28 65 6c 73 65 20 20 20 20 20 28 63 75 72 (else (cur
5f90: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 rent-seconds))))
5fa0: 0a 20 20 20 28 75 73 65 72 20 20 28 69 66 20 28 . (user (if (
5fb0: 61 6e 64 20 61 72 67 73 2d 61 6c 69 73 74 20 28 and args-alist (
5fc0: 68 61 73 68 2d 74 61 62 6c 65 3f 20 61 72 67 73 hash-table? args
5fd0: 2d 61 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 -alist)).
5fe0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
5ff0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 le-ref/default a
6000: 72 67 73 2d 61 6c 69 73 74 20 22 2d 6f 76 65 72 rgs-alist "-over
6010: 72 69 64 65 2d 75 73 65 72 22 20 28 63 75 72 72 ride-user" (curr
6020: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 0a ent-user-name)).
6030: 09 09 09 09 09 09 20 20 28 63 75 72 72 65 6e 74 ...... (current
6040: 2d 75 73 65 72 2d 6e 61 6d 65 29 29 29 0a 20 20 -user-name))).
6050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6060: 20 20 0a 09 20 28 61 72 67 73 2d 64 61 74 61 20 .. (args-data
6070: 28 69 66 20 61 72 67 73 2d 61 6c 69 73 74 0a 09 (if args-alist..
6080: 09 09 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c ..(if (hash-tabl
6090: 65 3f 20 61 72 67 73 2d 61 6c 69 73 74 29 20 3b e? args-alist) ;
60a0: 3b 20 73 65 72 69 6f 75 73 6c 79 3f 0a 09 09 09 ; seriously?....
60b0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
60c0: 3e 61 6c 69 73 74 20 61 72 67 73 2d 61 6c 69 73 >alist args-alis
60d0: 74 29 0a 09 09 09 20 20 20 20 61 72 67 73 2d 61 t).... args-a
60e0: 6c 69 73 74 29 0a 09 09 09 28 68 61 73 68 2d 74 list)....(hash-t
60f0: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 61 72 67 73 able->alist args
6100: 3a 61 72 67 2d 68 61 73 68 29 29 29 20 3b 3b 20 :arg-hash))) ;;
6110: 69 66 20 6e 6f 20 61 72 67 73 2d 61 6c 69 73 74 if no args-alist
6120: 20 74 68 65 6e 20 77 65 20 61 73 73 75 6d 65 20 then we assume
6130: 74 68 69 73 20 69 73 20 61 20 63 61 6c 6c 20 64 this is a call d
6140: 72 69 76 65 6e 20 64 69 72 65 63 74 6c 79 20 62 riven directly b
6150: 79 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 0a 09 20 y commandline..
6160: 28 61 6c 6c 64 61 74 20 20 20 20 28 61 70 70 6c (alldat (appl
6170: 79 20 61 70 70 65 6e 64 0a 09 09 09 20 20 20 28 y append.... (
6180: 6c 69 73 74 20 27 41 20 61 63 74 69 6f 6e 0a 09 list 'A action..
6190: 09 09 09 20 27 55 20 75 73 65 72 0a 09 09 09 09 ... 'U user.....
61a0: 20 27 44 20 73 63 68 65 64 29 0a 09 09 09 20 20 'D sched)....
61b0: 20 28 69 66 20 61 72 65 61 2d 70 61 74 68 0a 09 (if area-path..
61c0: 09 09 20 20 20 20 20 20 20 28 6c 69 73 74 20 27 .. (list '
61d0: 53 20 61 72 65 61 2d 70 61 74 68 29 20 3b 3b 20 S area-path) ;;
61e0: 74 68 65 20 61 72 65 61 2d 70 61 74 68 20 69 73 the area-path is
61f0: 20 6d 61 70 70 65 64 20 74 6f 20 74 68 65 20 73 mapped to the s
6200: 74 61 72 74 2d 64 69 72 0a 09 09 09 20 20 20 20 tart-dir....
6210: 20 20 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 '()).
6220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6230: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 65 78 (if (list? ex
6240: 74 72 61 2d 64 61 74 29 0a 09 09 09 20 20 20 20 tra-dat)....
6250: 20 20 20 65 78 74 72 61 2d 64 61 74 0a 09 09 09 extra-dat....
6260: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
6270: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
6280: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6290: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 6f 6d ort* "ERROR: com
62a0: 6d 61 6e 64 2d 6c 69 6e 65 2d 3e 70 6b 74 20 72 mand-line->pkt r
62b0: 65 63 65 69 76 65 64 20 62 61 64 20 65 78 74 72 eceived bad extr
62c0: 61 2d 64 61 74 20 22 20 65 78 74 72 61 2d 64 61 a-dat " extra-da
62d0: 74 29 0a 09 09 09 09 20 27 28 29 29 29 0a 09 09 t)..... '()))...
62e0: 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 . (map (lambda
62f0: 20 28 78 29 0a 09 09 09 09 20 20 28 6c 65 74 2a (x)..... (let*
6300: 20 28 28 70 61 72 61 6d 20 28 63 61 72 20 78 29 ((param (car x)
6310: 29 0a 09 09 09 09 09 20 28 76 61 6c 75 65 20 28 )...... (value (
6320: 63 64 72 20 78 29 29 0a 09 09 09 09 09 20 28 70 cdr x))...... (p
6330: 6d 65 74 61 20 28 61 73 73 6f 63 20 70 61 72 61 meta (assoc para
6340: 6d 20 2a 61 72 67 2d 6b 65 79 73 2a 29 29 20 20 m *arg-keys*))
6350: 20 20 3b 3b 20 74 72 61 6e 73 6c 61 74 65 20 74 ;; translate t
6360: 68 65 20 63 61 72 64 20 6b 65 79 20 74 6f 20 61 he card key to a
6370: 20 6d 65 67 61 74 65 73 74 20 73 77 69 74 63 68 megatest switch
6380: 20 6f 72 20 70 61 72 61 6d 65 74 65 72 0a 09 09 or parameter...
6390: 09 09 09 20 28 73 6d 65 74 61 20 28 61 73 73 6f ... (smeta (asso
63a0: 63 20 70 61 72 61 6d 20 2a 73 77 69 74 63 68 2d c param *switch-
63b0: 6b 65 79 73 2a 29 29 20 3b 3b 20 66 69 72 73 74 keys*)) ;; first
63c0: 20 6c 6f 6f 6b 75 70 20 74 68 65 20 6b 65 79 20 lookup the key
63d0: 69 6e 20 61 72 67 2d 6b 65 79 73 20 6f 72 20 73 in arg-keys or s
63e0: 77 69 74 63 68 2d 6b 65 79 73 0a 09 09 09 09 09 witch-keys......
63f0: 20 28 6d 65 74 61 20 20 28 69 66 20 28 6f 72 20 (meta (if (or
6400: 70 6d 65 74 61 20 73 6d 65 74 61 29 0a 09 09 09 pmeta smeta)....
6410: 09 09 09 20 20 20 20 28 63 64 72 20 28 6f 72 20 ... (cdr (or
6420: 70 6d 65 74 61 20 73 6d 65 74 61 29 29 20 20 20 pmeta smeta))
6430: 3b 3b 20 66 6f 75 6e 64 20 69 74 3f 0a 09 09 09 ;; found it?....
6440: 09 09 09 20 20 20 20 23 66 29 29 29 0a 20 20 20 ... #f))).
6450: 20 20 20 20 20 20 20 20 28 69 66 20 6d 65 74 61 (if meta
6460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6470: 20 20 20 20 20 3b 3b 20 63 6f 6e 73 74 72 75 63 ;; construc
6480: 74 20 74 68 65 20 73 77 69 74 63 68 2f 70 61 72 t the switch/par
6490: 61 6d 20 70 61 69 72 2e 0a 09 09 09 09 09 28 6c am pair.......(l
64a0: 69 73 74 20 6d 65 74 61 20 76 61 6c 75 65 29 0a ist meta value).
64b0: 09 09 09 09 09 27 28 29 29 29 29 0a 20 20 20 20 .....'()))).
64c0: 20 20 20 20 20 20 0a 09 09 09 09 28 66 69 6c 74 .....(filt
64d0: 65 72 20 63 64 72 20 61 72 67 73 2d 64 61 74 61 er cdr args-data
64e0: 29 29 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 ))))). (print
64f0: 20 20 22 41 6c 6c 64 61 74 3a 20 22 20 61 6c 6c "Alldat: " all
6500: 64 61 74 20 20 29 20 3b 3b 44 6f 20 6e 6f 74 20 dat ) ;;Do not
6510: 72 65 6d 6f 76 65 2e 20 54 68 69 73 20 69 73 20 remove. This is
6520: 75 65 73 65 64 20 62 79 20 6f 74 68 65 72 20 61 uesed by other a
6530: 70 70 6c 69 63 61 74 69 6f 6e 73 20 74 6f 20 63 pplications to c
6540: 61 6c 63 75 6c 61 74 65 20 7a 20 63 61 72 64 20 alculate z card
6550: 0a 20 20 20 20 3b 28 65 78 69 74 29 0a 20 20 20 . ;(exit).
6560: 20 28 61 64 64 2d 7a 2d 63 61 72 64 0a 20 20 20 (add-z-card.
6570: 20 20 28 61 70 70 6c 79 20 63 6f 6e 73 74 72 75 (apply constru
6580: 63 74 2d 73 64 61 74 20 61 6c 6c 64 61 74 29 29 ct-sdat alldat))
6590: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 69 6d ))..(define (sim
65a0: 70 6c 65 2d 73 65 74 75 70 20 73 74 61 72 74 2d ple-setup start-
65b0: 64 69 72 2d 69 6e 29 0a 20 20 28 6c 65 74 2a 20 dir-in). (let*
65c0: 28 28 73 74 61 72 74 2d 64 69 72 20 28 6f 72 20 ((start-dir (or
65d0: 73 74 61 72 74 2d 64 69 72 2d 69 6e 20 22 2e 22 start-dir-in "."
65e0: 29 29 0a 09 20 28 6d 74 63 6f 6e 66 69 67 20 20 )).. (mtconfig
65f0: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
6600: 67 20 22 2d 63 6f 6e 66 69 67 22 29 20 22 6d 65 g "-config") "me
6610: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 gatest.config"))
6620: 0a 09 20 28 6d 74 63 6f 6e 66 64 61 74 20 28 66 .. (mtconfdat (f
6630: 69 6e 64 2d 61 6e 64 2d 72 65 61 64 2d 63 6f 6e ind-and-read-con
6640: 66 69 67 20 20 20 20 20 20 20 20 3b 3b 20 4e 42 fig ;; NB
6650: 2f 2f 20 73 65 74 73 20 4d 54 5f 52 55 4e 5f 41 // sets MT_RUN_A
6660: 52 45 41 5f 48 4f 4d 45 20 61 73 20 73 69 64 65 REA_HOME as side
6670: 20 65 66 66 65 63 74 0a 09 09 20 20 20 20 20 6d effect... m
6680: 74 63 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 3b tconfig... ;
6690: 3b 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 ; environ-patt:
66a0: 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 22 0a 09 "env-override"..
66b0: 09 20 20 20 20 20 67 69 76 65 6e 2d 74 6f 70 70 . given-topp
66c0: 61 74 68 3a 20 73 74 61 72 74 2d 64 69 72 0a 09 ath: start-dir..
66d0: 09 20 20 20 20 20 3b 3b 20 70 61 74 68 65 6e 76 . ;; pathenv
66e0: 76 61 72 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 var: "MT_RUN_ARE
66f0: 41 5f 48 4f 4d 45 22 0a 09 09 20 20 20 20 20 29 A_HOME"... )
6700: 29 0a 09 20 28 6d 74 63 6f 6e 66 20 20 20 20 28 ).. (mtconf (
6710: 69 66 20 6d 74 63 6f 6e 66 64 61 74 20 28 63 61 if mtconfdat (ca
6720: 72 20 6d 74 63 6f 6e 66 64 61 74 29 20 23 66 29 r mtconfdat) #f)
6730: 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 73 65 74 )). ;; we set
6740: 20 73 6f 6d 65 20 64 79 6e 61 6d 69 63 20 64 61 some dynamic da
6750: 74 61 20 69 6e 20 61 20 73 65 63 74 69 6f 6e 20 ta in a section
6760: 63 61 6c 6c 65 64 20 22 73 63 72 61 74 63 68 64 called "scratchd
6770: 61 74 61 22 0a 20 20 20 20 28 69 66 20 6d 74 63 ata". (if mtc
6780: 6f 6e 66 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 onf..(begin.. (
6790: 63 6f 6e 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d configf:section-
67a0: 76 61 72 2d 73 65 74 21 20 6d 74 63 6f 6e 66 20 var-set! mtconf
67b0: 22 73 63 72 61 74 63 68 64 61 74 22 20 22 74 6f "scratchdat" "to
67c0: 70 70 61 74 68 22 20 73 74 61 72 74 2d 64 69 72 ppath" start-dir
67d0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e ))). ;; (prin
67e0: 74 20 22 54 4f 50 50 41 54 48 3a 20 22 20 28 63 t "TOPPATH: " (c
67f0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 onfigf:lookup mt
6800: 63 6f 6e 66 20 22 73 63 72 61 74 63 68 64 61 74 conf "scratchdat
6810: 22 20 22 74 6f 70 70 61 74 68 22 29 29 0a 20 20 " "toppath")).
6820: 20 20 6d 74 63 6f 6e 66 64 61 74 29 29 0a 0a 3b mtconfdat))..;
6830: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
6840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6870: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 72 65 61 73 =======.;; Areas
6880: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6c 6f =========..;; lo
68d0: 6f 6b 20 66 6f 72 20 61 72 65 61 73 3d 61 31 2c ok for areas=a1,
68e0: 61 32 2c 61 33 20 4f 52 20 61 72 65 61 66 6e 3d a2,a3 OR areafn=
68f0: 73 6f 6d 65 66 75 6e 63 6e 61 6d 65 0a 3b 3b 0a somefuncname.;;.
6900: 28 64 65 66 69 6e 65 20 28 76 61 6c 2d 61 6c 69 (define (val-ali
6910: 73 74 2d 3e 61 72 65 61 73 20 76 61 6c 2d 61 6c st->areas val-al
6920: 69 73 74 29 0a 20 20 28 6c 65 74 20 28 28 61 72 ist). (let ((ar
6930: 65 61 73 2d 73 74 72 69 6e 67 20 20 20 28 61 6c eas-string (al
6940: 69 73 74 2d 72 65 66 20 27 61 72 65 61 73 20 20 ist-ref 'areas
6950: 76 61 6c 2d 61 6c 69 73 74 29 29 0a 09 28 61 72 val-alist))..(ar
6960: 65 61 73 2d 70 72 6f 63 6e 61 6d 65 20 28 61 6c eas-procname (al
6970: 69 73 74 2d 72 65 66 20 27 61 72 65 61 66 6e 20 ist-ref 'areafn
6980: 76 61 6c 2d 61 6c 69 73 74 29 29 29 0a 20 20 20 val-alist))).
6990: 20 28 69 66 20 61 72 65 61 73 2d 70 72 6f 63 6e (if areas-procn
69a0: 61 6d 65 20 3b 3b 20 61 72 65 61 73 2d 70 72 6f ame ;; areas-pro
69b0: 63 6e 61 6d 65 20 74 61 6b 65 20 70 72 65 63 65 cname take prece
69c0: 64 65 6e 63 65 0a 09 61 72 65 61 73 2d 70 72 6f dence..areas-pro
69d0: 63 6e 61 6d 65 0a 09 28 73 74 72 69 6e 67 2d 73 cname..(string-s
69e0: 70 6c 69 74 20 28 6f 72 20 61 72 65 61 73 2d 73 plit (or areas-s
69f0: 74 72 69 6e 67 20 22 22 29 20 22 2c 22 29 29 29 tring "") ",")))
6a00: 29 0a 0a 3b 3b 20 61 72 65 61 20 20 20 2d 20 74 )..;; area - t
6a10: 68 65 20 63 75 72 72 65 6e 74 20 61 72 65 61 20 he current area
6a20: 75 6e 64 65 72 20 63 6f 6e 73 69 64 65 72 61 74 under considerat
6a30: 69 6f 6e 0a 3b 3b 20 61 72 65 61 73 20 20 2d 20 ion.;; areas -
6a40: 74 68 65 20 6c 69 73 74 20 6f 66 20 61 6c 6c 6f the list of allo
6a50: 77 65 64 20 61 72 65 61 73 20 66 72 6f 6d 20 74 wed areas from t
6a60: 68 65 20 63 6f 6e 74 6f 75 72 20 73 70 65 63 20 he contour spec
6a70: 2d 4f 52 2d 0a 3b 3b 20 20 20 20 20 20 20 20 20 -OR-.;;
6a80: 20 69 66 20 69 74 20 69 73 20 61 20 73 74 72 69 if it is a stri
6a90: 6e 67 20 74 68 65 6e 20 69 74 20 69 73 20 74 68 ng then it is th
6aa0: 65 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 75 73 e function to us
6ab0: 65 20 74 6f 0a 3b 3b 20 20 20 20 20 20 20 20 20 e to.;;
6ac0: 20 6c 6f 6f 6b 75 70 20 69 6e 20 2a 61 72 65 61 lookup in *area
6ad0: 2d 63 68 65 63 6b 65 72 73 2a 0a 3b 3b 0a 28 64 -checkers*.;;.(d
6ae0: 65 66 69 6e 65 20 28 61 72 65 61 2d 61 6c 6c 6f efine (area-allo
6af0: 77 65 64 3f 20 61 72 65 61 20 61 72 65 61 73 20 wed? area areas
6b00: 72 75 6e 6b 65 79 20 63 6f 6e 74 6f 75 72 20 6d runkey contour m
6b10: 6f 64 65 2d 70 61 74 74 29 0a 20 20 3b 3b 28 70 ode-patt). ;;(p
6b20: 72 69 6e 74 20 22 41 72 65 61 73 3a 20 22 20 61 rint "Areas: " a
6b30: 72 65 61 73 29 0a 20 20 28 63 6f 6e 64 0a 20 20 reas). (cond.
6b40: 20 28 28 6e 6f 74 20 61 72 65 61 73 29 20 23 74 ((not areas) #t
6b50: 29 20 3b 3b 20 6e 6f 20 73 70 65 63 0a 20 20 20 ) ;; no spec.
6b60: 28 28 73 74 72 69 6e 67 3f 20 61 72 65 61 73 29 ((string? areas)
6b70: 20 3b 3b 20 0a 20 20 20 20 28 6c 65 74 20 28 28 ;; . (let ((
6b80: 63 68 65 63 6b 2d 66 6e 20 28 68 61 73 68 2d 74 check-fn (hash-t
6b90: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
6ba0: 20 2a 61 72 65 61 2d 63 68 65 63 6b 65 72 73 2a *area-checkers*
6bb0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
6bc0: 20 61 72 65 61 73 29 20 23 66 29 29 29 0a 20 20 areas) #f))).
6bd0: 20 20 20 20 28 69 66 20 63 68 65 63 6b 2d 66 6e (if check-fn
6be0: 0a 09 20 20 28 63 68 65 63 6b 2d 66 6e 20 61 72 .. (check-fn ar
6bf0: 65 61 20 72 75 6e 6b 65 79 20 63 6f 6e 74 6f 75 ea runkey contou
6c00: 72 20 6d 6f 64 65 2d 70 61 74 74 29 0a 09 20 20 r mode-patt)..
6c10: 23 66 29 29 29 0a 20 20 20 28 28 6c 69 73 74 3f #f))). ((list?
6c20: 20 61 72 65 61 73 29 28 6d 65 6d 62 65 72 20 61 areas)(member a
6c30: 72 65 61 20 61 72 65 61 73 29 29 0a 20 20 20 28 rea areas)). (
6c40: 65 6c 73 65 20 23 66 29 29 29 20 3b 3b 20 73 68 else #f))) ;; sh
6c50: 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 ouldn't get here
6c60: 20 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d ..(define (get-
6c70: 61 72 65 61 2d 6e 61 6d 65 73 20 6d 74 63 6f 6e area-names mtcon
6c80: 66 29 0a 20 20 28 6d 61 70 20 63 61 72 20 28 63 f). (map car (c
6c90: 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 onfigf:get-secti
6ca0: 6f 6e 20 6d 74 63 6f 6e 66 20 22 61 72 65 61 73 on mtconf "areas
6cb0: 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ")))..;;========
6cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
6d00: 3b 20 50 6b 74 73 20 66 6f 72 20 72 65 6d 6f 74 ; Pkts for remot
6d10: 65 20 63 6f 6e 74 72 6f 6c 0a 3b 3b 3d 3d 3d 3d e control.;;====
6d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d60: 3d 3d 0a 0a 3b 3b 20 4e 45 45 44 20 54 49 4d 45 ==..;; NEED TIME
6d70: 53 54 41 4d 50 20 4f 4e 20 50 4b 54 53 20 66 6f STAMP ON PKTS fo
6d80: 72 20 65 66 66 69 63 69 65 6e 74 20 6c 6f 61 64 r efficient load
6d90: 69 6e 67 20 6f 66 20 70 61 63 6b 65 74 73 20 69 ing of packets i
6da0: 6e 74 6f 20 64 62 2e 0a 0a 0a 3b 3b 20 6d 61 6b nto db....;; mak
6db0: 65 20 61 20 72 75 6e 20 72 65 71 75 65 73 74 20 e a run request
6dc0: 70 6b 74 20 66 72 6f 6d 20 62 61 73 69 63 20 64 pkt from basic d
6dd0: 61 74 61 2c 20 74 68 69 73 20 73 65 72 69 6f 75 ata, this seriou
6de0: 73 6c 79 20 6e 65 65 64 73 20 74 6f 20 62 65 20 sly needs to be
6df0: 72 65 66 61 63 74 6f 72 65 64 0a 3b 3b 20 20 20 refactored.;;
6e00: 69 2e 20 54 61 6b 65 20 74 68 65 20 63 6f 64 65 i. Take the code
6e10: 20 74 68 61 74 20 62 75 69 6c 64 73 20 74 68 65 that builds the
6e20: 20 69 6e 66 6f 20 74 6f 20 73 75 62 6d 69 74 20 info to submit
6e30: 74 6f 20 63 72 65 61 74 65 2d 72 75 6e 2d 70 6b to create-run-pk
6e40: 74 20 61 6e 64 20 68 61 76 65 20 69 74 0a 3b 3b t and have it.;;
6e50: 20 20 20 20 20 20 67 65 6e 65 72 61 74 65 20 74 generate t
6e60: 68 65 20 70 6b 74 20 6b 65 79 73 20 64 69 72 65 he pkt keys dire
6e70: 63 74 6c 79 2e 0a 3b 3b 20 20 69 69 2e 20 50 61 ctly..;; ii. Pa
6e80: 73 73 20 74 68 65 20 70 6b 74 20 6b 65 79 73 20 ss the pkt keys
6e90: 61 6e 64 20 76 61 6c 75 65 73 20 74 6f 20 74 68 and values to th
6ea0: 69 73 20 70 72 6f 63 20 61 6e 64 20 67 6f 20 66 is proc and go f
6eb0: 72 6f 6d 20 74 68 65 72 65 2e 0a 3b 3b 20 69 69 rom there..;; ii
6ec0: 69 2e 20 4d 61 79 62 65 20 68 61 76 65 20 61 6e i. Maybe have an
6ed0: 20 61 62 73 74 72 61 63 74 69 6f 6e 20 61 6c 69 abstraction ali
6ee0: 73 74 20 77 69 74 68 20 6d 65 61 6e 69 6e 67 66 st with meaningf
6ef0: 75 6c 20 6e 61 6d 65 73 20 66 6f 72 20 74 68 65 ul names for the
6f00: 20 70 6b 74 20 6b 65 79 73 0a 3b 3b 0a 3b 3b 20 pkt keys.;;.;;
6f10: 4f 76 65 72 72 69 64 65 20 74 68 65 20 72 75 6e Override the run
6f20: 20 73 74 61 72 74 20 74 69 6d 65 20 72 65 63 6f start time reco
6f30: 72 64 20 77 69 74 68 20 73 63 68 65 64 2e 20 55 rd with sched. U
6f40: 73 75 61 6c 6c 79 20 23 66 20 69 73 20 66 69 6e sually #f is fin
6f50: 65 2e 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 e..;; .(define (
6f60: 63 72 65 61 74 65 2d 72 75 6e 2d 70 6b 74 20 6d create-run-pkt m
6f70: 74 63 6f 6e 66 20 61 63 74 69 6f 6e 20 61 72 65 tconf action are
6f80: 61 20 72 75 6e 6b 65 79 20 74 61 72 67 65 74 20 a runkey target
6f90: 72 75 6e 6e 61 6d 65 20 6d 6f 64 65 2d 70 61 74 runname mode-pat
6fa0: 74 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t .
6fb0: 20 20 20 20 20 20 20 20 20 20 20 74 61 67 2d 65 tag-e
6fc0: 78 70 72 20 70 6b 74 73 64 69 72 20 72 65 61 73 xpr pktsdir reas
6fd0: 6f 6e 20 63 6f 6e 74 6f 75 72 20 73 63 68 65 64 on contour sched
6fe0: 20 64 62 64 65 73 74 20 61 70 70 65 6e 64 2d 63 dbdest append-c
6ff0: 6f 6e 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 onf.
7000: 20 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 74 runt
7010: 72 61 6e 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 rans). (let* ((
7020: 67 6f 6f 64 2d 76 61 6c 20 20 20 28 6c 61 6d 62 good-val (lamb
7030: 64 61 20 28 69 6e 76 61 6c 29 28 61 6e 64 20 69 da (inval)(and i
7040: 6e 76 61 6c 20 28 73 74 72 69 6e 67 3f 20 69 6e nval (string? in
7050: 76 61 6c 29 28 6e 6f 74 20 28 73 74 72 69 6e 67 val)(not (string
7060: 2d 6e 75 6c 6c 3f 20 69 6e 76 61 6c 29 29 29 29 -null? inval))))
7070: 29 0a 09 20 28 61 72 65 61 2d 64 61 74 20 20 20 ).. (area-dat
7080: 28 63 6f 6d 6d 6f 6e 3a 76 61 6c 2d 3e 61 6c 69 (common:val->ali
7090: 73 74 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a st (or (configf:
70a0: 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 61 lookup mtconf "a
70b0: 72 65 61 73 22 20 61 72 65 61 29 20 22 22 29 29 reas" area) ""))
70c0: 29 0a 09 20 28 61 72 65 61 2d 70 61 74 68 20 20 ).. (area-path
70d0: 28 61 6c 69 73 74 2d 72 65 66 20 27 70 61 74 68 (alist-ref 'path
70e0: 20 20 20 20 20 20 61 72 65 61 2d 64 61 74 29 29 area-dat))
70f0: 0a 09 20 3b 3b 20 28 61 72 65 61 2d 78 6c 61 74 .. ;; (area-xlat
7100: 72 20 28 61 6c 69 73 74 2d 72 65 66 20 27 74 61 r (alist-ref 'ta
7110: 72 67 74 72 61 6e 73 20 61 72 65 61 2d 64 61 74 rgtrans area-dat
7120: 29 29 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 28 )). ;; (
7130: 78 6c 61 74 72 2d 6b 65 79 20 20 28 69 66 20 61 xlatr-key (if a
7140: 72 65 61 2d 78 6c 61 74 72 20 28 73 74 72 69 6e rea-xlatr (strin
7150: 67 2d 3e 73 79 6d 62 6f 6c 20 61 72 65 61 2d 78 g->symbol area-x
7160: 6c 61 74 72 29 20 23 66 29 29 0a 20 20 20 20 20 latr) #f)).
7170: 20 20 20 20 28 6e 65 77 2d 72 75 6e 6e 61 6d 65 (new-runname
7180: 20 28 6c 65 74 2a 20 28 28 63 61 6c 6c 6e 61 6d (let* ((callnam
7190: 65 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 e (if (string? r
71a0: 75 6e 74 72 61 6e 73 29 28 73 74 72 69 6e 67 2d untrans)(string-
71b0: 3e 73 79 6d 62 6f 6c 20 72 75 6e 74 72 61 6e 73 >symbol runtrans
71c0: 29 20 23 66 29 29 0a 09 09 09 20 20 20 20 20 28 ) #f)).... (
71d0: 6d 61 70 70 65 72 20 20 20 28 69 66 20 63 61 6c mapper (if cal
71e0: 6c 6e 61 6d 65 20 28 68 61 73 68 2d 74 61 62 6c lname (hash-tabl
71f0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 72 e-ref/default *r
7200: 75 6e 6e 61 6d 65 2d 6d 61 70 70 65 72 73 2a 20 unname-mappers*
7210: 63 61 6c 6c 6e 61 6d 65 20 23 66 29 20 23 66 29 callname #f) #f)
7220: 29 29 0a 09 09 09 3b 3b 20 28 70 72 69 6e 74 20 ))....;; (print
7230: 22 63 61 6c 6c 6e 61 6d 65 3d 22 20 63 61 6c 6c "callname=" call
7240: 6e 61 6d 65 20 22 20 72 75 6e 74 72 61 6e 73 3d name " runtrans=
7250: 22 20 72 75 6e 74 72 61 6e 73 20 22 20 6d 61 70 " runtrans " map
7260: 70 65 72 3d 22 20 6d 61 70 70 65 72 29 0a 09 09 per=" mapper)...
7270: 09 28 69 66 20 28 61 6e 64 20 63 61 6c 6c 6e 61 .(if (and callna
7280: 6d 65 0a 09 09 09 09 20 28 6e 6f 74 20 28 65 71 me..... (not (eq
7290: 75 61 6c 3f 20 63 61 6c 6c 6e 61 6d 65 20 22 61 ual? callname "a
72a0: 75 74 6f 22 29 29 0a 09 09 09 09 20 28 6e 6f 74 uto"))..... (not
72b0: 20 6d 61 70 70 65 72 29 29 0a 09 09 09 20 20 20 mapper))....
72c0: 20 28 70 72 69 6e 74 20 22 4e 6f 20 6d 61 70 70 (print "No mapp
72d0: 65 72 20 22 20 63 61 6c 6c 6e 61 6d 65 20 22 20 er " callname "
72e0: 66 6f 72 20 61 72 65 61 20 22 20 61 72 65 61 20 for area " area
72f0: 22 20 75 73 69 6e 67 20 22 20 63 61 6c 6c 6e 61 " using " callna
7300: 6d 65 20 22 20 61 73 20 74 68 65 20 72 75 6e 6e me " as the runn
7310: 61 6d 65 22 29 29 0a 09 09 09 28 69 66 20 6d 61 ame"))....(if ma
7320: 70 70 65 72 0a 09 09 09 20 20 20 20 28 68 61 6e pper.... (han
7330: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
7340: 09 09 09 65 78 6e 0a 09 09 09 09 28 62 65 67 69 ...exn.....(begi
7350: 6e 0a 09 09 09 09 20 20 28 70 72 69 6e 74 2d 63 n..... (print-c
7360: 61 6c 6c 2d 63 68 61 69 6e 29 0a 09 09 09 09 20 all-chain).....
7370: 20 28 70 72 69 6e 74 20 22 46 41 49 4c 45 44 20 (print "FAILED
7380: 54 4f 20 52 55 4e 20 52 55 4e 4e 41 4d 45 20 4d TO RUN RUNNAME M
7390: 41 50 50 45 52 20 22 20 63 61 6c 6c 6e 61 6d 65 APPER " callname
73a0: 20 22 20 46 4f 52 20 41 52 45 41 20 22 20 61 72 " FOR AREA " ar
73b0: 65 61 29 0a 09 09 09 09 20 20 28 70 72 69 6e 74 ea)..... (print
73c0: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
73d0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
73e0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
73f0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
7400: 0a 09 09 09 09 20 20 72 75 6e 6e 61 6d 65 29 0a ..... runname).
7410: 09 09 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 ... (print
7420: 22 28 6d 61 70 70 65 72 20 22 20 28 73 74 72 69 "(mapper " (stri
7430: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
7440: 6c 69 73 74 20 72 75 6e 6b 65 79 20 72 75 6e 6e list runkey runn
7450: 61 6d 65 20 61 72 65 61 20 61 72 65 61 2d 70 61 ame area area-pa
7460: 74 68 20 72 65 61 73 6f 6e 20 63 6f 6e 74 6f 75 th reason contou
7470: 72 20 6d 6f 64 65 2d 70 61 74 74 29 20 22 2c 20 r mode-patt) ",
7480: 22 29 20 22 29 22 29 0a 09 09 09 20 20 20 20 20 ") ")")....
7490: 20 28 6d 61 70 70 65 72 20 72 75 6e 6b 65 79 20 (mapper runkey
74a0: 72 75 6e 6e 61 6d 65 20 61 72 65 61 20 61 72 65 runname area are
74b0: 61 2d 70 61 74 68 20 72 65 61 73 6f 6e 20 63 6f a-path reason co
74c0: 6e 74 6f 75 72 20 6d 6f 64 65 2d 70 61 74 74 29 ntour mode-patt)
74d0: 29 0a 09 09 09 20 20 20 20 28 63 61 73 65 20 63 ).... (case c
74e0: 61 6c 6c 6e 61 6d 65 0a 09 09 09 20 20 20 20 20 allname....
74f0: 20 28 28 61 75 74 6f 20 23 66 29 20 72 75 6e 6e ((auto #f) runn
7500: 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 28 65 ame).... (e
7510: 6c 73 65 20 20 20 72 75 6e 74 72 61 6e 73 29 29 lse runtrans))
7520: 29 29 29 0a 09 20 28 6e 65 77 2d 74 61 72 67 65 ))).. (new-targe
7530: 74 20 20 20 20 20 74 61 72 67 65 74 29 20 3b 3b t target) ;;
7540: 20 49 20 62 65 6c 69 65 76 65 20 77 65 20 77 69 I believe we wi
7550: 6c 6c 20 77 61 6e 74 20 74 61 72 67 65 74 20 6d ll want target m
7560: 61 6e 69 70 75 6c 61 74 69 6f 6e 20 68 65 72 65 anipulation here
7570: 20 2e 2e 20 28 6d 61 70 2d 74 61 72 67 65 74 73 .. (map-targets
7580: 20 78 6c 61 74 72 2d 6b 65 79 20 72 75 6e 6b 65 xlatr-key runke
7590: 79 20 61 72 65 61 20 63 6f 6e 74 6f 75 72 29 29 y area contour))
75a0: 0a 09 20 28 61 63 74 75 61 6c 2d 61 63 74 69 6f .. (actual-actio
75b0: 6e 20 20 28 69 66 20 61 63 74 69 6f 6e 0a 09 09 n (if action...
75c0: 09 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c . (if (equal
75d0: 3f 20 61 63 74 69 6f 6e 20 22 73 79 6e 63 2d 70 ? action "sync-p
75e0: 72 65 70 65 6e 64 22 29 0a 09 09 09 09 20 22 73 repend")..... "s
75f0: 79 6e 63 22 0a 09 09 09 09 20 61 63 74 69 6f 6e ync"..... action
7600: 29 0a 09 09 09 20 20 20 20 20 22 72 75 6e 22 29 ).... "run")
7610: 29 29 20 3b 3b 20 74 68 69 73 20 68 61 73 20 67 )) ;; this has g
7620: 6f 74 74 65 6e 20 61 20 62 69 74 20 75 67 6c 79 otten a bit ugly
7630: 2e 20 4e 65 65 64 20 61 20 66 75 6e 63 74 69 6f . Need a functio
7640: 6e 20 74 6f 20 68 61 6e 64 6c 65 20 61 63 74 69 n to handle acti
7650: 6f 6e 73 20 70 72 6f 63 65 73 73 69 6e 67 2e 0a ons processing..
7660: 20 20 20 20 3b 3b 20 73 6f 6d 65 20 68 61 63 6b ;; some hack
7670: 73 20 74 6f 20 72 65 6d 6f 76 65 20 73 77 69 74 s to remove swit
7680: 63 68 65 73 20 6e 6f 74 20 6e 65 65 64 65 64 20 ches not needed
7690: 69 6e 20 63 65 72 74 61 69 6e 20 63 61 73 65 73 in certain cases
76a0: 0a 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 . (case (stri
76b0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 6f 72 20 61 ng->symbol (or a
76c0: 63 74 69 6f 6e 20 22 72 75 6e 22 29 29 0a 20 20 ction "run")).
76d0: 20 20 20 20 28 28 73 79 6e 63 20 73 79 6e 63 2d ((sync sync-
76e0: 70 72 65 70 65 6e 64 29 0a 20 20 20 20 20 20 20 prepend).
76f0: 28 73 65 74 21 20 6e 65 77 2d 74 61 72 67 65 74 (set! new-target
7700: 20 23 66 29 0a 20 20 20 20 20 20 20 28 73 65 74 #f). (set
7710: 21 20 72 75 6e 61 6d 65 20 20 20 20 20 23 66 29 ! runame #f)
7720: 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
7730: 20 22 61 72 65 61 2d 70 61 74 68 3a 20 22 20 61 "area-path: " a
7740: 72 65 61 2d 70 61 74 68 20 22 20 6f 72 69 67 2d rea-path " orig-
7750: 74 61 72 67 65 74 3a 20 22 20 72 75 6e 6b 65 79 target: " runkey
7760: 20 22 20 6e 65 77 2d 74 61 72 67 65 74 3a 20 22 " new-target: "
7770: 20 6e 65 77 2d 74 61 72 67 65 74 29 0a 20 20 20 new-target).
7780: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 (let-values (((
7790: 75 75 69 64 20 70 6b 74 29 0a 09 09 20 20 28 63 uuid pkt)... (c
77a0: 6f 6d 6d 61 6e 64 2d 6c 69 6e 65 2d 3e 70 6b 74 ommand-line->pkt
77b0: 0a 09 09 20 20 20 61 63 74 75 61 6c 2d 61 63 74 ... actual-act
77c0: 69 6f 6e 0a 09 09 20 20 20 28 61 70 70 65 6e 64 ion... (append
77d0: 20 0a 09 09 20 20 20 20 60 28 28 22 2d 73 74 61 ... `(("-sta
77e0: 72 74 2d 64 69 72 22 20 20 2e 20 2c 61 72 65 61 rt-dir" . ,area
77f0: 2d 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 3b -path)... ;
7800: 3b 28 22 2d 6d 73 67 22 20 20 20 20 20 20 20 20 ;("-msg"
7810: 2e 20 2c 72 65 61 73 6f 6e 29 0a 20 20 20 20 20 . ,reason).
7820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7830: 20 28 22 2d 6d 73 67 22 20 20 20 20 20 20 20 20 ("-msg"
7840: 2e 20 2c 22 53 63 72 69 70 74 2d 74 72 69 67 67 . ,"Script-trigg
7850: 65 72 65 64 22 29 0a 09 09 20 20 20 20 20 20 28 ered")... (
7860: 22 2d 63 6f 6e 74 6f 75 72 22 20 20 20 20 2e 20 "-contour" .
7870: 2c 63 6f 6e 74 6f 75 72 29 29 0a 09 09 20 20 20 ,contour))...
7880: 20 28 69 66 20 28 67 6f 6f 64 2d 76 61 6c 20 6e (if (good-val n
7890: 65 77 2d 72 75 6e 6e 61 6d 65 29 20 60 28 28 22 ew-runname) `(("
78a0: 2d 72 75 6e 2d 6e 61 6d 65 22 20 20 20 20 20 20 -run-name"
78b0: 2e 20 2c 6e 65 77 2d 72 75 6e 6e 61 6d 65 29 29 . ,new-runname))
78c0: 20 27 28 29 29 0a 09 09 20 20 20 20 28 69 66 20 '())... (if
78d0: 28 67 6f 6f 64 2d 76 61 6c 20 6e 65 77 2d 74 61 (good-val new-ta
78e0: 72 67 65 74 29 20 20 60 28 28 22 2d 74 61 72 67 rget) `(("-targ
78f0: 65 74 22 20 20 20 20 20 20 20 20 2e 20 2c 6e 65 et" . ,ne
7900: 77 2d 74 61 72 67 65 74 29 29 20 20 27 28 29 29 w-target)) '())
7910: 0a 09 09 20 20 20 20 28 69 66 20 28 67 6f 6f 64 ... (if (good
7920: 2d 76 61 6c 20 61 72 65 61 29 20 20 20 20 20 20 -val area)
7930: 20 20 60 28 28 22 2d 61 72 65 61 22 20 20 20 20 `(("-area"
7940: 20 20 20 20 20 20 2e 20 2c 61 72 65 61 29 29 20 . ,area))
7950: 20 20 20 20 20 20 20 27 28 29 29 0a 09 09 20 20 '())...
7960: 20 20 28 69 66 20 28 67 6f 6f 64 2d 76 61 6c 20 (if (good-val
7970: 6d 6f 64 65 2d 70 61 74 74 29 20 20 20 60 28 28 mode-patt) `((
7980: 22 2d 6d 6f 64 65 2d 70 61 74 74 22 20 20 20 20 "-mode-patt"
7990: 20 2e 20 2c 6d 6f 64 65 2d 70 61 74 74 29 29 20 . ,mode-patt))
79a0: 20 20 27 28 29 29 0a 09 09 20 20 20 20 28 69 66 '())... (if
79b0: 20 28 67 6f 6f 64 2d 76 61 6c 20 74 61 67 2d 65 (good-val tag-e
79c0: 78 70 72 29 20 20 20 20 60 28 28 22 2d 74 61 67 xpr) `(("-tag
79d0: 2d 65 78 70 72 22 20 20 20 20 20 20 2e 20 2c 74 -expr" . ,t
79e0: 61 67 2d 65 78 70 72 29 29 20 20 20 20 27 28 29 ag-expr)) '()
79f0: 29 0a 09 09 20 20 20 20 28 69 66 20 28 67 6f 6f )... (if (goo
7a00: 64 2d 76 61 6c 20 64 62 64 65 73 74 29 20 20 20 d-val dbdest)
7a10: 20 20 20 60 28 28 22 2d 73 79 6e 63 2d 74 6f 22 `(("-sync-to"
7a20: 20 20 20 20 20 20 20 2e 20 2c 64 62 64 65 73 74 . ,dbdest
7a30: 29 29 20 20 20 20 20 20 27 28 29 29 0a 09 09 20 )) '())...
7a40: 20 20 20 28 69 66 20 28 67 6f 6f 64 2d 76 61 6c (if (good-val
7a50: 20 61 70 70 65 6e 64 2d 63 6f 6e 66 29 20 60 28 append-conf) `(
7a60: 28 22 2d 61 70 70 65 6e 64 2d 63 6f 6e 66 69 67 ("-append-config
7a70: 22 20 2e 20 2c 61 70 70 65 6e 64 2d 63 6f 6e 66 " . ,append-conf
7a80: 29 29 20 27 28 29 29 0a 09 09 20 20 20 20 28 69 )) '())... (i
7a90: 66 20 28 65 71 75 61 6c 3f 20 61 63 74 69 6f 6e f (equal? action
7aa0: 20 22 73 79 6e 63 2d 70 72 65 70 65 6e 64 22 29 "sync-prepend")
7ab0: 20 27 28 28 22 2d 70 72 65 70 65 6e 64 2d 63 6f '(("-prepend-co
7ac0: 6e 74 6f 75 72 22 20 2e 20 22 20 22 29 29 20 20 ntour" . " "))
7ad0: 20 27 28 29 29 0a 09 09 20 20 20 20 28 69 66 20 '())... (if
7ae0: 28 6e 6f 74 20 28 6f 72 20 6d 6f 64 65 2d 70 61 (not (or mode-pa
7af0: 74 74 20 74 61 67 2d 65 78 70 72 29 29 0a 09 09 tt tag-expr))...
7b00: 09 60 28 28 22 2d 74 65 73 74 70 61 74 74 22 20 .`(("-testpatt"
7b10: 20 2e 20 22 25 22 29 29 0a 09 09 09 27 28 29 29 . "%"))....'())
7b20: 0a 09 09 20 20 20 20 28 69 66 20 28 6f 72 20 28 ... (if (or (
7b30: 6e 6f 74 20 61 63 74 69 6f 6e 29 0a 09 09 09 20 not action)....
7b40: 20 20 20 28 65 71 75 61 6c 3f 20 61 63 74 69 6f (equal? actio
7b50: 6e 20 22 72 75 6e 22 29 29 0a 09 09 09 60 28 28 n "run"))....`((
7b60: 22 2d 70 72 65 63 6c 65 61 6e 22 20 20 2e 20 22 "-preclean" . "
7b70: 20 22 29 0a 09 09 09 20 20 28 22 2d 72 65 72 75 ").... ("-reru
7b80: 6e 2d 61 6c 6c 22 20 2e 20 22 20 22 29 29 20 20 n-all" . " "))
7b90: 20 20 20 20 3b 3b 20 69 66 20 72 75 6e 20 77 65 ;; if run we
7ba0: 20 2a 61 6c 77 61 79 73 2a 20 77 61 6e 74 20 70 *always* want p
7bb0: 72 65 63 6c 65 61 6e 20 73 65 74 2c 20 75 73 65 reclean set, use
7bc0: 20 73 69 6e 67 6c 65 20 73 70 61 63 65 20 61 73 single space as
7bd0: 20 70 6c 61 63 65 68 6f 6c 64 65 72 0a 09 09 09 placeholder....
7be0: 27 28 29 29 0a 09 09 20 20 20 20 29 0a 09 09 20 '())... )...
7bf0: 20 20 73 63 68 65 64 0a 20 20 20 20 20 20 20 20 sched.
7c00: 20 20 20 20 20 20 20 20 20 20 20 65 78 74 72 61 extra
7c10: 2d 64 61 74 3a 20 60 28 61 20 2c 72 75 6e 6b 65 -dat: `(a ,runke
7c20: 79 29 20 20 3b 3b 20 77 65 20 6e 65 65 64 20 74 y) ;; we need t
7c30: 68 65 20 72 75 6e 20 6b 65 79 20 66 6f 72 20 6d he run key for m
7c40: 61 72 6b 69 6e 67 20 74 68 65 20 72 75 6e 20 61 arking the run a
7c50: 73 20 6c 61 75 6e 63 68 65 64 0a 20 20 20 20 20 s launched.
7c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
7c70: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 ). (with-ou
7c80: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 0a 09 20 20 tput-to-file..
7c90: 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 2f (conc pktsdir "/
7ca0: 22 20 75 75 69 64 20 22 2e 70 6b 74 22 29 0a 09 " uuid ".pkt")..
7cb0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 70 (lambda ().. (p
7cc0: 72 69 6e 74 20 70 6b 74 29 29 29 29 29 29 0a 0a rint pkt))))))..
7cd0: 3b 3b 20 28 75 73 65 20 74 72 61 63 65 29 28 74 ;; (use trace)(t
7ce0: 72 61 63 65 20 63 72 65 61 74 65 2d 72 75 6e 2d race create-run-
7cf0: 70 6b 74 29 0a 28 64 65 66 69 6e 65 20 28 63 6f pkt).(define (co
7d00: 6e 74 61 69 6e 73 20 6c 69 73 74 20 78 29 20 28 ntains list x) (
7d10: 63 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 6c 69 73 cond ((null? lis
7d20: 74 29 20 23 66 29 20 28 28 65 71 3f 20 28 63 61 t) #f) ((eq? (ca
7d30: 72 20 6c 69 73 74 29 20 78 29 20 23 74 29 20 28 r list) x) #t) (
7d40: 65 6c 73 65 20 28 63 6f 6e 74 61 69 6e 73 20 28 else (contains (
7d50: 63 64 72 20 6c 69 73 74 29 20 78 29 29 29 29 0a cdr list) x)))).
7d60: 0a 3b 3b 20 63 6f 6c 6c 65 63 74 20 61 6c 6c 20 .;; collect all
7d70: 6e 65 65 64 65 64 20 64 61 74 61 20 61 6e 64 20 needed data and
7d80: 63 72 65 61 74 65 20 72 75 6e 20 70 6b 74 73 20 create run pkts
7d90: 66 6f 72 20 63 6f 6e 74 6f 75 72 73 20 77 69 74 for contours wit
7da0: 68 20 63 68 61 6e 67 65 64 20 69 6e 70 75 74 73 h changed inputs
7db0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 6e .;;.(define (gen
7dc0: 65 72 61 74 65 2d 72 75 6e 2d 70 6b 74 73 20 6d erate-run-pkts m
7dd0: 74 63 6f 6e 66 20 74 6f 70 70 61 74 68 29 0a 20 tconf toppath).
7de0: 20 28 6c 65 74 20 28 28 73 74 64 2d 72 75 6e 6e (let ((std-runn
7df0: 61 6d 65 20 28 63 6f 6e 63 20 22 73 63 68 65 64 ame (conc "sched
7e00: 22 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 " (time->string
7e10: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
7e20: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
7e30: 65 63 6f 6e 64 73 29 29 20 22 25 4d 25 48 25 64 econds)) "%M%H%d
7e40: 22 29 29 29 0a 20 20 20 20 20 20 20 20 28 70 61 "))). (pa
7e50: 63 6b 65 74 73 2d 67 65 6e 65 72 61 74 65 64 20 ckets-generated
7e60: 30 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 0)). (common:
7e70: 77 69 74 68 2d 71 75 65 75 65 2d 64 62 0a 20 20 with-queue-db.
7e80: 20 20 20 6d 74 63 6f 6e 66 0a 20 20 20 20 20 28 mtconf. (
7e90: 6c 61 6d 62 64 61 20 28 70 6b 74 73 64 69 72 73 lambda (pktsdirs
7ea0: 20 70 6b 74 73 64 69 72 20 70 64 62 29 0a 20 20 pktsdir pdb).
7eb0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 67 63 (let* ((rgc
7ec0: 6f 6e 66 64 61 74 20 28 66 69 6e 64 2d 61 6e 64 onfdat (find-and
7ed0: 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f -read-config (co
7ee0: 6e 63 20 74 6f 70 70 61 74 68 20 22 2f 72 75 6e nc toppath "/run
7ef0: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
7f00: 29 29 0a 09 20 20 20 20 20 20 28 72 67 63 6f 6e )).. (rgcon
7f10: 66 20 20 20 20 28 63 61 72 20 72 67 63 6f 6e 66 f (car rgconf
7f20: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 61 6c dat)).. (al
7f30: 6c 2d 61 72 65 61 73 20 28 6d 61 70 20 63 61 72 l-areas (map car
7f40: 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 (configf:get-se
7f50: 63 74 69 6f 6e 20 6d 74 63 6f 6e 66 20 22 61 72 ction mtconf "ar
7f60: 65 61 73 22 29 29 29 0a 09 20 20 20 20 20 20 28 eas"))).. (
7f70: 63 6f 6e 74 6f 75 72 73 20 20 28 63 6f 6e 66 69 contours (confi
7f80: 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 6d gf:get-section m
7f90: 74 63 6f 6e 66 20 22 63 6f 6e 74 6f 75 72 73 22 tconf "contours"
7fa0: 29 29 0a 09 20 20 20 20 20 20 28 74 6f 72 75 6e )).. (torun
7fb0: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
7fc0: 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 table)) ;; targe
7fd0: 74 20 3d 3e 20 28 20 2e 2e 2e 20 69 6e 66 6f 20 t => ( ... info
7fe0: 2e 2e 2e 20 29 0a 09 20 20 20 20 20 20 28 72 67 ... ).. (rg
7ff0: 65 6e 74 61 72 67 73 20 28 68 61 73 68 2d 74 61 entargs (hash-ta
8000: 62 6c 65 2d 6b 65 79 73 20 72 67 63 6f 6e 66 29 ble-keys rgconf)
8010: 29 29 20 3b 3b 20 74 68 65 73 65 20 61 72 65 20 )) ;; these are
8020: 74 68 65 20 74 61 72 67 65 74 73 20 72 65 67 69 the targets regi
8030: 73 74 65 72 65 64 20 66 6f 72 20 61 75 74 6f 6d stered for autom
8040: 61 74 69 63 61 6c 6c 79 20 74 72 69 67 67 65 72 atically trigger
8050: 69 6e 67 0a 0a 09 20 3b 3b 28 70 72 69 6e 74 20 ing... ;;(print
8060: 22 72 67 65 6e 74 61 72 67 73 3a 20 22 20 72 67 "rgentargs: " rg
8070: 65 6e 74 61 72 67 73 29 0a 09 20 20 28 66 6f 72 entargs).. (for
8080: 2d 65 61 63 68 0a 09 20 20 28 6c 61 6d 62 64 61 -each.. (lambda
8090: 20 28 72 75 6e 6b 65 79 29 0a 09 20 20 20 20 28 (runkey).. (
80a0: 6c 65 74 2a 20 28 28 6b 65 79 64 61 74 73 20 20 let* ((keydats
80b0: 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 (configf:get-se
80c0: 63 74 69 6f 6e 20 72 67 63 6f 6e 66 20 72 75 6e ction rgconf run
80d0: 6b 65 79 29 29 29 0a 09 20 20 20 20 20 20 28 66 key))).. (f
80e0: 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 20 20 or-each..
80f0: 28 6c 61 6d 62 64 61 20 28 73 65 6e 73 65 29 20 (lambda (sense)
8100: 3b 3b 20 74 68 65 73 65 20 61 72 65 20 74 68 65 ;; these are the
8110: 20 73 65 6e 73 65 20 72 75 6c 65 73 0a 09 09 20 sense rules...
8120: 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 20 (let* ((key
8130: 20 20 20 28 63 61 72 20 73 65 6e 73 65 29 29 0a (car sense)).
8140: 09 09 09 28 76 61 6c 20 20 20 20 20 20 20 20 28 ...(val (
8150: 63 61 64 72 20 73 65 6e 73 65 29 29 0a 09 09 09 cadr sense))....
8160: 28 6b 65 79 70 61 72 74 73 20 20 20 28 73 74 72 (keyparts (str
8170: 69 6e 67 2d 73 70 6c 69 74 20 6b 65 79 20 22 3a ing-split key ":
8180: 22 29 29 20 3b 3b 20 63 6f 6e 74 6f 75 72 3a 72 ")) ;; contour:r
8190: 75 6c 65 74 79 70 65 3a 61 63 74 69 6f 6e 3a 6f uletype:action:o
81a0: 70 74 69 6f 6e 61 6c 0a 09 09 09 28 63 6f 6e 74 ptional....(cont
81b0: 6f 75 72 20 20 20 20 28 63 61 72 20 6b 65 79 70 our (car keyp
81c0: 61 72 74 73 29 29 0a 09 09 09 28 6c 65 6e 2d 6b arts))....(len-k
81d0: 65 79 20 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 ey (length ke
81e0: 79 70 61 72 74 73 29 29 0a 09 09 09 28 72 75 6c yparts))....(rul
81f0: 65 74 79 70 65 20 20 20 28 69 66 20 28 3e 20 6c etype (if (> l
8200: 65 6e 2d 6b 65 79 20 31 29 28 63 61 64 72 20 6b en-key 1)(cadr k
8210: 65 79 70 61 72 74 73 29 20 23 66 29 29 0a 09 09 eyparts) #f))...
8220: 09 28 61 63 74 69 6f 6e 20 20 20 20 20 28 69 66 .(action (if
8230: 20 28 3e 20 6c 65 6e 2d 6b 65 79 20 32 29 28 63 (> len-key 2)(c
8240: 61 64 64 72 20 6b 65 79 70 61 72 74 73 29 20 23 addr keyparts) #
8250: 66 29 29 0a 09 09 09 28 6f 70 74 69 6f 6e 61 6c f))....(optional
8260: 20 20 20 28 69 66 20 28 3e 20 6c 65 6e 2d 6b 65 (if (> len-ke
8270: 79 20 33 29 28 63 61 64 64 64 72 20 6b 65 79 70 y 3)(cadddr keyp
8280: 61 72 74 73 29 20 23 66 29 29 0a 09 09 09 3b 3b arts) #f))....;;
8290: 20 28 76 61 6c 2d 6c 69 73 74 20 20 20 28 73 74 (val-list (st
82a0: 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 ring-split-field
82b0: 73 20 22 3b 5c 5c 73 2a 22 20 76 61 6c 20 23 3a s ";\\s*" val #:
82c0: 69 6e 66 69 78 29 29 20 3b 3b 20 28 73 74 72 69 infix)) ;; (stri
82d0: 6e 67 2d 73 70 6c 69 74 20 76 61 6c 29 29 20 3b ng-split val)) ;
82e0: 3b 20 72 75 6e 6e 61 6d 65 2d 72 75 6c 65 20 70 ; runname-rule p
82f0: 61 72 61 6d 73 0a 09 09 09 28 76 61 6c 2d 61 6c arams....(val-al
8300: 69 73 74 20 20 28 63 6f 6d 6d 6f 6e 3a 76 61 6c ist (common:val
8310: 2d 3e 61 6c 69 73 74 20 76 61 6c 29 29 0a 09 09 ->alist val))...
8320: 09 28 72 75 6e 6e 61 6d 65 20 20 20 20 28 6d 61 .(runname (ma
8330: 6b 65 2d 72 75 6e 6e 61 6d 65 20 22 22 20 22 22 ke-runname "" ""
8340: 29 29 0a 09 09 09 28 72 75 6e 74 72 61 6e 73 20 ))....(runtrans
8350: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 (alist-ref 'ru
8360: 6e 74 72 61 6e 73 20 76 61 6c 2d 61 6c 69 73 74 ntrans val-alist
8370: 29 29 0a 0a 09 09 09 3b 3b 20 74 68 65 73 65 20 )).....;; these
8380: 6d 61 79 20 6f 72 20 6d 61 79 20 6e 6f 74 20 62 may or may not b
8390: 65 20 64 65 66 69 6e 65 64 20 61 6e 64 20 6e 6f e defined and no
83a0: 74 20 61 6c 6c 20 61 72 65 20 75 73 65 64 20 69 t all are used i
83b0: 6e 20 65 61 63 68 20 68 61 6e 64 6c 65 72 20 74 n each handler t
83c0: 79 70 65 20 69 6e 20 74 68 65 20 63 61 73 65 20 ype in the case
83d0: 62 65 6c 6f 77 0a 09 09 09 28 72 75 6e 2d 6e 61 below....(run-na
83e0: 6d 65 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 me (alist-ref
83f0: 27 72 75 6e 2d 6e 61 6d 65 20 76 61 6c 2d 61 6c 'run-name val-al
8400: 69 73 74 29 29 0a 09 09 09 28 74 61 72 67 65 74 ist))....(target
8410: 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 (alist-ref
8420: 27 74 61 72 67 65 74 20 20 20 76 61 6c 2d 61 6c 'target val-al
8430: 69 73 74 29 29 0a 09 09 09 28 63 72 6f 6e 74 61 ist))....(cronta
8440: 62 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 b (alist-ref
8450: 27 63 72 6f 6e 20 20 20 20 20 76 61 6c 2d 61 6c 'cron val-al
8460: 69 73 74 29 29 0a 09 09 09 28 61 72 65 61 73 20 ist))....(areas
8470: 20 20 20 20 20 28 76 61 6c 2d 61 6c 69 73 74 2d (val-alist-
8480: 3e 61 72 65 61 73 20 20 20 20 76 61 6c 2d 61 6c >areas val-al
8490: 69 73 74 29 29 20 3b 3b 20 61 72 65 61 73 20 63 ist)) ;; areas c
84a0: 61 6e 20 62 65 20 61 20 73 69 6e 67 6c 65 20 73 an be a single s
84b0: 74 72 69 6e 67 20 28 61 20 72 65 66 65 72 65 6e tring (a referen
84c0: 63 65 20 74 6f 20 63 61 6c 6c 20 61 6e 20 61 72 ce to call an ar
84d0: 65 61 73 20 66 75 6e 63 74 69 6f 6e 29 2c 20 6f eas function), o
84e0: 72 20 61 20 6c 69 73 74 20 6f 66 20 61 72 65 61 r a list of area
84f0: 20 6e 61 6d 65 73 2e 0a 09 09 09 28 64 62 64 65 names.....(dbde
8500: 73 74 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 st (alist-re
8510: 66 20 27 64 62 64 65 73 74 20 20 20 76 61 6c 2d f 'dbdest val-
8520: 61 6c 69 73 74 29 29 0a 09 09 09 28 61 70 70 65 alist))....(appe
8530: 6e 64 63 6f 6e 66 20 28 61 6c 69 73 74 2d 72 65 ndconf (alist-re
8540: 66 20 27 61 70 70 65 6e 64 63 6f 6e 66 20 76 61 f 'appendconf va
8550: 6c 2d 61 6c 69 73 74 29 29 0a 09 09 09 28 66 69 l-alist))....(fi
8560: 6c 65 2d 67 6c 6f 62 73 20 28 61 6c 69 73 74 2d le-globs (alist-
8570: 72 65 66 20 27 67 6c 6f 62 20 76 61 6c 2d 61 6c ref 'glob val-al
8580: 69 73 74 29 29 0a 09 09 09 0a 09 09 09 28 72 75 ist))........(ru
8590: 6e 73 74 61 72 74 73 20 20 28 66 69 6e 64 2d 70 nstarts (find-p
85a0: 6b 74 73 20 70 64 62 20 27 28 72 75 6e 73 74 61 kts pdb '(runsta
85b0: 72 74 29 20 60 28 28 63 20 2e 20 2c 63 6f 6e 74 rt) `((c . ,cont
85c0: 6f 75 72 29 0a 09 09 09 09 09 09 09 09 20 28 74 our)......... (t
85d0: 20 2e 20 2c 72 75 6e 6b 65 79 29 29 29 29 0a 09 . ,runkey))))..
85e0: 09 09 28 72 73 70 6b 74 73 20 20 20 20 20 28 63 ..(rspkts (c
85f0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 2d 61 6c ommon:get-pkt-al
8600: 69 73 74 73 20 72 75 6e 73 74 61 72 74 73 29 29 ists runstarts))
8610: 0a 09 09 09 3b 3b 20 73 74 61 72 74 74 69 6d 65 ....;; starttime
8620: 73 20 69 73 20 66 6f 72 20 72 75 6e 20 73 74 61 s is for run sta
8630: 72 74 20 74 69 6d 65 73 20 61 6e 64 20 69 73 20 rt times and is
8640: 75 73 65 64 20 74 6f 20 6b 6e 6f 77 20 77 68 65 used to know whe
8650: 6e 20 74 68 65 20 6c 61 73 74 20 72 75 6e 20 77 n the last run w
8660: 61 73 20 6c 61 75 6e 63 68 65 64 0a 09 09 09 28 as launched....(
8670: 73 74 61 72 74 74 69 6d 65 73 20 28 63 6f 6d 6d starttimes (comm
8680: 6f 6e 3a 67 65 74 2d 70 6b 74 2d 74 69 6d 65 73 on:get-pkt-times
8690: 20 72 73 70 6b 74 73 29 29 20 3b 3b 20 73 6f 72 rspkts)) ;; sor
86a0: 74 20 62 79 20 61 67 65 20 28 79 6f 75 6e 67 65 t by age (younge
86b0: 73 74 20 66 69 72 73 74 29 20 61 6e 64 20 64 65 st first) and de
86c0: 6c 65 74 65 20 64 75 70 6c 69 63 61 74 65 73 20 lete duplicates
86d0: 62 79 20 74 61 72 67 65 74 0a 09 09 09 28 6c 61 by target....(la
86e0: 73 74 2d 72 75 6e 20 20 20 28 69 66 20 28 6e 75 st-run (if (nu
86f0: 6c 6c 3f 20 73 74 61 72 74 74 69 6d 65 73 29 20 ll? starttimes)
8700: 3b 3b 20 69 66 20 27 28 29 20 74 68 65 6e 20 69 ;; if '() then i
8710: 74 20 68 61 73 20 6e 65 76 65 72 20 62 65 65 6e t has never been
8720: 20 72 75 6e 2c 20 65 6c 73 65 20 67 65 74 20 74 run, else get t
8730: 68 65 20 6d 61 78 0a 09 09 09 09 09 30 0a 09 09 he max......0...
8740: 09 09 09 28 61 70 70 6c 79 20 6d 61 78 20 28 6d ...(apply max (m
8750: 61 70 20 63 64 72 20 73 74 61 72 74 74 69 6d 65 ap cdr starttime
8760: 73 29 29 29 29 0a 09 09 09 3b 3b 20 73 79 6e 63 s))))....;; sync
8770: 74 69 6d 65 73 20 69 73 20 66 6f 72 20 66 69 67 times is for fig
8780: 75 72 69 6e 67 20 6f 75 74 20 74 68 65 20 6c 61 uring out the la
8790: 73 74 20 74 69 6d 65 20 61 20 73 79 6e 63 20 77 st time a sync w
87a0: 61 73 20 64 6f 6e 65 0a 09 09 09 28 73 79 6e 63 as done....(sync
87b0: 73 74 61 72 74 73 20 28 66 69 6e 64 2d 70 6b 74 starts (find-pkt
87c0: 73 20 70 64 62 20 27 28 73 79 6e 63 73 74 61 72 s pdb '(syncstar
87d0: 74 29 20 27 28 29 29 29 20 3b 3b 20 6e 6f 20 71 t) '())) ;; no q
87e0: 75 61 6c 69 66 69 65 72 73 2c 20 61 20 73 79 6e ualifiers, a syn
87f0: 63 20 64 6f 65 73 20 61 6c 6c 20 74 61 72 65 74 c does all taret
8800: 73 20 65 74 63 2e 0a 09 09 09 28 73 73 70 6b 74 s etc.....(sspkt
8810: 73 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a s (common:
8820: 67 65 74 2d 70 6b 74 2d 61 6c 69 73 74 73 20 73 get-pkt-alists s
8830: 79 6e 63 73 74 61 72 74 73 29 29 0a 09 09 09 28 yncstarts))....(
8840: 73 79 6e 63 74 69 6d 65 73 20 20 20 20 28 63 6f synctimes (co
8850: 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 2d 74 69 6d mmon:get-pkt-tim
8860: 65 73 20 20 73 73 70 6b 74 73 29 29 0a 09 09 09 es sspkts))....
8870: 28 6c 61 73 74 2d 73 79 6e 63 20 20 28 69 66 20 (last-sync (if
8880: 28 6e 75 6c 6c 3f 20 73 79 6e 63 74 69 6d 65 73 (null? synctimes
8890: 29 20 3b 3b 20 69 66 20 27 28 29 20 74 68 65 6e ) ;; if '() then
88a0: 20 69 74 20 68 61 73 20 6e 65 76 65 72 20 62 65 it has never be
88b0: 65 6e 20 72 75 6e 2c 20 65 6c 73 65 20 67 65 74 en run, else get
88c0: 20 74 68 65 20 6d 61 78 0a 09 09 09 09 09 30 0a the max......0.
88d0: 09 09 09 09 09 28 61 70 70 6c 79 20 6d 61 78 20 .....(apply max
88e0: 28 6d 61 70 20 63 64 72 20 73 79 6e 63 74 69 6d (map cdr synctim
88f0: 65 73 29 29 29 29 0a 09 09 09 29 0a 0a 09 09 20 es))))....)....
8900: 20 20 28 6c 65 74 20 28 28 64 65 6c 74 61 20 28 (let ((delta (
8910: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 lambda (x).....
8920: 20 28 72 6f 75 6e 64 20 28 2f 20 28 2d 20 28 63 (round (/ (- (c
8930: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
8940: 78 29 20 36 30 29 29 29 29 29 0a 20 20 20 20 20 x) 60))))).
8950: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 72 67 (if (arg
8960: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
8970: 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 et").
8980: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d (if (string=
8990: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
89a0: 2d 74 61 72 67 65 74 22 29 20 72 75 6e 6b 65 79 -target") runkey
89b0: 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 )... (begi
89c0: 6e 20 28 70 72 69 6e 74 20 22 72 75 6e 6b 65 79 n (print "runkey
89d0: 3a 20 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 : " runkey ", ru
89e0: 6c 65 74 79 70 65 3a 20 22 20 72 75 6c 65 74 79 letype: " rulety
89f0: 70 65 20 22 2c 20 61 63 74 69 6f 6e 3a 20 22 20 pe ", action: "
8a00: 61 63 74 69 6f 6e 20 22 2c 20 6c 61 73 74 2d 72 action ", last-r
8a10: 75 6e 3a 20 22 20 6c 61 73 74 2d 72 75 6e 20 22 un: " last-run "
8a20: 20 74 69 6d 65 20 73 69 6e 63 65 3b 20 6c 61 73 time since; las
8a30: 74 2d 72 75 6e 3a 20 22 20 28 64 65 6c 74 61 20 t-run: " (delta
8a40: 6c 61 73 74 2d 72 75 6e 29 20 22 2c 20 6c 61 73 last-run) ", las
8a50: 74 2d 73 79 6e 63 3a 20 22 20 28 64 65 6c 74 61 t-sync: " (delta
8a60: 20 6c 61 73 74 2d 73 79 6e 63 29 29 0a 09 09 20 last-sync))...
8a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
8a80: 69 6e 74 20 22 76 61 6c 2d 61 6c 69 73 74 3d 22 int "val-alist="
8a90: 20 76 61 6c 2d 61 6c 69 73 74 20 22 20 72 75 6e val-alist " run
8aa0: 74 72 61 6e 73 3d 22 20 72 75 6e 74 72 61 6e 73 trans=" runtrans
8ab0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8ac0: 20 20 28 69 66 20 23 66 20 28 70 72 69 6e 74 20 (if #f (print
8ad0: 22 73 6b 69 70 70 69 6e 67 3a 20 22 20 72 75 6e "skipping: " run
8ae0: 6b 65 79 29 29 29 0a 09 09 20 20 20 20 20 20 20 key)))...
8af0: 28 62 65 67 69 6e 20 28 70 72 69 6e 74 20 22 72 (begin (print "r
8b00: 75 6e 6b 65 79 3a 20 22 20 72 75 6e 6b 65 79 20 unkey: " runkey
8b10: 22 2c 20 72 75 6c 65 74 79 70 65 3a 20 22 20 72 ", ruletype: " r
8b20: 75 6c 65 74 79 70 65 20 22 2c 20 61 63 74 69 6f uletype ", actio
8b30: 6e 3a 20 22 20 61 63 74 69 6f 6e 20 22 2c 20 6c n: " action ", l
8b40: 61 73 74 2d 72 75 6e 3a 20 22 20 6c 61 73 74 2d ast-run: " last-
8b50: 72 75 6e 20 22 20 74 69 6d 65 20 73 69 6e 63 65 run " time since
8b60: 3b 20 6c 61 73 74 2d 72 75 6e 3a 20 22 20 28 64 ; last-run: " (d
8b70: 65 6c 74 61 20 6c 61 73 74 2d 72 75 6e 29 20 22 elta last-run) "
8b80: 2c 20 6c 61 73 74 2d 73 79 6e 63 3a 20 22 20 28 , last-sync: " (
8b90: 64 65 6c 74 61 20 6c 61 73 74 2d 73 79 6e 63 29 delta last-sync)
8ba0: 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 20 20 )...
8bb0: 20 20 28 70 72 69 6e 74 20 22 76 61 6c 2d 61 6c (print "val-al
8bc0: 69 73 74 3d 22 20 76 61 6c 2d 61 6c 69 73 74 20 ist=" val-alist
8bd0: 22 20 72 75 6e 74 72 61 6e 73 3d 22 20 72 75 6e " runtrans=" run
8be0: 74 72 61 6e 73 29 29 0a 20 20 20 20 20 20 20 20 trans)).
8bf0: 20 20 20 29 29 0a 0a 09 09 20 20 20 0a 09 09 20 )).... ...
8c00: 20 20 3b 3b 20 6c 6f 6f 6b 20 69 6e 20 72 75 6e ;; look in run
8c10: 73 74 61 72 74 73 20 66 6f 72 20 6d 61 74 63 68 starts for match
8c20: 69 6e 67 20 72 75 6e 73 20 62 79 20 74 61 72 67 ing runs by targ
8c30: 65 74 20 61 6e 64 20 63 6f 6e 74 6f 75 72 0a 09 et and contour..
8c40: 09 20 20 20 3b 3b 20 67 65 74 20 74 68 65 20 74 . ;; get the t
8c50: 69 6d 65 73 74 61 6d 70 20 66 6f 72 20 77 68 65 imestamp for whe
8c60: 6e 20 74 68 61 74 20 72 75 6e 20 73 74 61 72 74 n that run start
8c70: 65 64 20 61 6e 64 20 70 61 73 73 20 69 74 0a 09 ed and pass it..
8c80: 09 20 20 20 3b 3b 20 74 6f 20 74 68 65 20 72 75 . ;; to the ru
8c90: 6c 65 20 6c 6f 67 69 63 20 68 65 72 65 20 77 68 le logic here wh
8ca0: 65 72 65 20 22 72 75 6c 65 74 79 70 65 22 20 77 ere "ruletype" w
8cb0: 69 6c 6c 20 62 65 20 61 70 70 6c 69 65 64 0a 09 ill be applied..
8cc0: 09 20 20 20 3b 3b 20 69 66 20 69 74 20 63 6f 6d . ;; if it com
8cd0: 65 73 20 62 61 63 6b 20 22 63 68 61 6e 67 65 64 es back "changed
8ce0: 22 20 74 68 65 6e 20 70 72 6f 63 65 65 64 20 74 " then proceed t
8cf0: 6f 20 72 65 67 69 73 74 65 72 20 74 68 65 20 72 o register the r
8d00: 75 6e 73 0a 09 09 20 20 20 0a 09 09 20 20 20 28 uns... ... (
8d10: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
8d20: 6d 62 6f 6c 20 28 6f 72 20 72 75 6c 65 74 79 70 mbol (or ruletyp
8d30: 65 20 22 6e 6f 2d 73 75 63 68 2d 72 75 6c 65 22 e "no-such-rule"
8d40: 29 29 0a 0a 09 09 20 20 20 20 20 28 28 6e 6f 2d )).... ((no-
8d50: 73 75 63 68 2d 72 75 6c 65 29 20 28 70 72 69 6e such-rule) (prin
8d60: 74 20 22 45 52 52 4f 52 3a 20 6e 6f 20 73 75 63 t "ERROR: no suc
8d70: 68 20 72 75 6c 65 20 66 6f 72 20 22 20 73 65 6e h rule for " sen
8d80: 73 65 29 29 0a 0a 09 09 20 20 20 20 20 3b 3b 20 se)).... ;;
8d90: 48 61 6e 64 6c 65 20 63 72 6f 6e 74 61 62 20 6c Handle crontab l
8da0: 69 6b 65 20 72 75 6c 65 73 0a 09 09 20 20 20 20 ike rules...
8db0: 20 3b 3b 0a 09 09 20 20 20 20 20 28 28 73 63 68 ;;... ((sch
8dc0: 65 64 75 6c 65 64 29 0a 09 09 20 20 20 20 20 20 eduled)...
8dd0: 28 69 66 20 28 6e 6f 74 20 28 61 6c 69 73 74 2d (if (not (alist-
8de0: 72 65 66 20 27 63 72 6f 6e 20 76 61 6c 2d 61 6c ref 'cron val-al
8df0: 69 73 74 29 29 20 3b 3b 20 67 6f 74 74 61 20 68 ist)) ;; gotta h
8e00: 61 76 65 20 63 72 6f 6e 20 73 70 65 63 0a 09 09 ave cron spec...
8e10: 09 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 . (print "ERROR
8e20: 3a 20 62 61 64 20 73 65 6e 73 65 20 73 70 65 63 : bad sense spec
8e30: 20 5c 22 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 \"" (string-int
8e40: 65 72 73 70 65 72 73 65 20 73 65 6e 73 65 20 22 ersperse sense "
8e50: 20 22 29 20 22 5c 22 20 70 61 72 61 6d 73 3a 20 ") "\" params:
8e60: 22 20 76 61 6c 2d 61 6c 69 73 74 29 0a 09 09 09 " val-alist)....
8e70: 20 20 28 6c 65 74 2a 20 28 0a 09 09 09 09 20 3b (let* (..... ;
8e80: 3b 20 28 61 63 74 69 6f 6e 20 20 20 28 61 6c 69 ; (action (ali
8e90: 73 74 2d 72 65 66 20 27 61 63 74 69 6f 6e 20 20 st-ref 'action
8ea0: 20 76 61 6c 2d 61 6c 69 73 74 29 29 0a 09 09 09 val-alist))....
8eb0: 09 20 28 63 72 6f 6e 2d 73 61 66 65 2d 73 74 72 . (cron-safe-str
8ec0: 69 6e 67 20 28 73 74 72 69 6e 67 2d 74 72 61 6e ing (string-tran
8ed0: 73 6c 61 74 65 20 28 73 74 72 69 6e 67 2d 69 6e slate (string-in
8ee0: 74 65 72 73 70 65 72 73 65 20 28 73 74 72 69 6e tersperse (strin
8ef0: 67 2d 73 70 6c 69 74 20 63 72 6f 6e 74 61 62 29 g-split crontab)
8f00: 20 22 2d 22 29 20 22 2a 22 20 22 58 22 29 29 0a "-") "*" "X")).
8f10: 09 09 09 09 20 28 72 75 6e 6e 61 6d 65 20 20 73 .... (runname s
8f20: 74 64 2d 72 75 6e 6e 61 6d 65 29 29 20 3b 3b 20 td-runname)) ;;
8f30: 28 63 6f 6e 63 20 22 73 63 68 65 64 22 20 28 74 (conc "sched" (t
8f40: 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 ime->string (sec
8f50: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
8f60: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
8f70: 73 29 29 20 22 25 4d 25 48 25 64 22 29 29 29 29 s)) "%M%H%d"))))
8f80: 29 0a 09 09 09 20 20 20 20 3b 3b 20 28 70 72 69 ).... ;; (pri
8f90: 6e 74 20 22 6c 61 73 74 2d 72 75 6e 3a 20 22 20 nt "last-run: "
8fa0: 6c 61 73 74 2d 72 75 6e 20 22 20 6e 65 65 64 2d last-run " need-
8fb0: 72 75 6e 3a 20 22 20 6e 65 65 64 2d 72 75 6e 29 run: " need-run)
8fc0: 0a 09 09 09 20 20 20 20 3b 3b 20 28 69 66 20 6e .... ;; (if n
8fd0: 65 65 64 2d 72 75 6e 0a 09 09 09 20 20 20 20 28 eed-run.... (
8fe0: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
8ff0: 6d 62 6f 6c 20 61 63 74 69 6f 6e 29 0a 09 09 09 mbol action)....
9000: 20 20 20 20 20 20 28 28 73 79 6e 63 20 73 79 6e ((sync syn
9010: 63 2d 70 72 65 70 65 6e 64 29 0a 09 09 09 20 20 c-prepend)....
9020: 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e (if (common
9030: 3a 65 78 74 65 6e 64 65 64 2d 63 72 6f 6e 20 63 :extended-cron c
9040: 72 6f 6e 74 61 62 20 23 66 20 6c 61 73 74 2d 73 rontab #f last-s
9050: 79 6e 63 29 0a 09 09 09 09 20 20 20 28 70 75 73 ync)..... (pus
9060: 68 2d 72 75 6e 2d 73 70 65 63 20 74 6f 72 75 6e h-run-spec torun
9070: 20 63 6f 6e 74 6f 75 72 20 72 75 6e 6b 65 79 0a contour runkey.
9080: 09 09 09 09 09 09 20 20 60 28 28 6d 65 73 73 61 ...... `((messa
9090: 67 65 20 2e 20 2c 28 63 6f 6e 63 20 72 75 6c 65 ge . ,(conc rule
90a0: 74 79 70 65 20 22 3a 73 79 6e 63 2d 22 20 63 72 type ":sync-" cr
90b0: 6f 6e 2d 73 61 66 65 2d 73 74 72 69 6e 67 29 29 on-safe-string))
90c0: 0a 09 09 09 09 09 09 20 20 20 20 28 61 63 74 69 ....... (acti
90d0: 6f 6e 20 20 2e 20 2c 61 63 74 69 6f 6e 29 0a 09 on . ,action)..
90e0: 09 09 09 09 09 20 20 20 20 28 64 62 64 65 73 74 ..... (dbdest
90f0: 20 20 2e 20 2c 64 62 64 65 73 74 29 0a 09 09 09 . ,dbdest)....
9100: 09 09 09 20 20 20 20 28 61 70 70 65 6e 64 20 20 ... (append
9110: 2e 20 2c 61 70 70 65 6e 64 63 6f 6e 66 29 0a 09 . ,appendconf)..
9120: 09 09 09 09 09 20 20 20 20 28 61 72 65 61 73 20 ..... (areas
9130: 20 20 2e 20 2c 61 72 65 61 73 29 29 29 29 29 0a . ,areas))))).
9140: 09 09 09 20 20 20 20 20 20 28 28 72 75 6e 29 0a ... ((run).
9150: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 63 ... (if (c
9160: 6f 6d 6d 6f 6e 3a 65 78 74 65 6e 64 65 64 2d 63 ommon:extended-c
9170: 72 6f 6e 20 63 72 6f 6e 74 61 62 20 23 66 20 6c ron crontab #f l
9180: 61 73 74 2d 72 75 6e 29 0a 09 09 09 09 20 20 20 ast-run).....
9190: 28 70 75 73 68 2d 72 75 6e 2d 73 70 65 63 20 74 (push-run-spec t
91a0: 6f 72 75 6e 20 63 6f 6e 74 6f 75 72 20 72 75 6e orun contour run
91b0: 6b 65 79 0a 09 09 09 09 09 09 20 20 60 28 28 6d key....... `((m
91c0: 65 73 73 61 67 65 20 20 2e 20 2c 28 63 6f 6e 63 essage . ,(conc
91d0: 20 72 75 6c 65 74 79 70 65 20 22 3a 22 20 63 72 ruletype ":" cr
91e0: 6f 6e 2d 73 61 66 65 2d 73 74 72 69 6e 67 29 29 on-safe-string))
91f0: 0a 09 09 09 09 09 09 20 20 20 20 28 72 75 6e 6e ....... (runn
9200: 61 6d 65 20 20 2e 20 2c 72 75 6e 6e 61 6d 65 29 ame . ,runname)
9210: 0a 09 09 09 09 09 09 20 20 20 20 28 72 75 6e 74 ....... (runt
9220: 72 61 6e 73 20 2e 20 2c 72 75 6e 74 72 61 6e 73 rans . ,runtrans
9230: 29 0a 09 09 09 09 09 09 20 20 20 20 28 61 63 74 )....... (act
9240: 69 6f 6e 20 20 20 2e 20 2c 61 63 74 69 6f 6e 29 ion . ,action)
9250: 0a 09 09 09 09 09 09 20 20 20 20 28 61 72 65 61 ....... (area
9260: 73 20 20 20 20 2e 20 2c 61 72 65 61 73 29 0a 09 s . ,areas)..
9270: 09 09 09 09 09 20 20 20 20 28 74 61 72 67 65 74 ..... (target
9280: 20 20 20 2e 20 2c 74 61 72 67 65 74 29 29 29 29 . ,target))))
9290: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
92a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92b0: 28 28 72 65 6d 6f 76 65 29 0a 20 20 20 20 20 20 ((remove).
92c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92d0: 20 20 20 20 20 20 20 20 20 28 70 75 73 68 2d 72 (push-r
92e0: 75 6e 2d 73 70 65 63 20 74 6f 72 75 6e 20 63 6f un-spec torun co
92f0: 6e 74 6f 75 72 20 72 75 6e 6b 65 79 0a 09 09 09 ntour runkey....
9300: 09 09 09 20 20 60 28 28 6d 65 73 73 61 67 65 20 ... `((message
9310: 20 2e 20 2c 28 63 6f 6e 63 20 72 75 6c 65 74 79 . ,(conc rulety
9320: 70 65 20 22 3a 22 20 63 72 6f 6e 2d 73 61 66 65 pe ":" cron-safe
9330: 2d 73 74 72 69 6e 67 29 29 0a 09 09 09 09 09 09 -string)).......
9340: 20 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 2e 20 (runname .
9350: 2c 72 75 6e 6e 61 6d 65 29 0a 09 09 09 09 09 09 ,runname).......
9360: 20 20 20 20 28 72 75 6e 74 72 61 6e 73 20 2e 20 (runtrans .
9370: 2c 72 75 6e 74 72 61 6e 73 29 0a 09 09 09 09 09 ,runtrans)......
9380: 09 20 20 20 20 28 61 63 74 69 6f 6e 20 20 20 2e . (action .
9390: 20 2c 61 63 74 69 6f 6e 29 0a 09 09 09 09 09 09 ,action).......
93a0: 20 20 20 20 28 61 72 65 61 73 20 20 20 20 2e 20 (areas .
93b0: 2c 61 72 65 61 73 29 0a 09 09 09 09 09 09 20 20 ,areas).......
93c0: 20 20 28 74 61 72 67 65 74 20 20 20 2e 20 2c 74 (target . ,t
93d0: 61 72 67 65 74 29 29 29 29 0a 09 09 09 20 20 20 arget))))....
93e0: 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 (else....
93f0: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
9400: 3a 20 61 63 74 69 6f 6e 20 5c 22 22 20 61 63 74 : action \"" act
9410: 69 6f 6e 20 22 5c 22 20 68 61 73 20 6e 6f 20 73 ion "\" has no s
9420: 63 68 65 64 75 6c 65 64 20 68 61 6e 64 6c 65 72 cheduled handler
9430: 22 29 0a 09 09 09 20 20 20 20 20 20 20 29 29 29 ").... )))
9440: 29 29 0a 0a 0a 09 09 20 20 20 20 20 3b 3b 20 73 ))..... ;; s
9450: 63 72 69 70 74 20 62 61 73 65 64 20 73 65 6e 73 cript based sens
9460: 6f 72 73 0a 09 09 20 20 20 20 20 3b 3b 0a 09 09 ors... ;;...
9470: 20 20 20 20 20 28 28 73 63 72 69 70 74 29 0a 09 ((script)..
9480: 09 20 20 20 20 20 20 3b 3b 20 73 79 6e 74 61 78 . ;; syntax
9490: 20 69 73 20 61 20 6c 69 74 74 6c 65 20 64 69 66 is a little dif
94a0: 66 65 72 65 6e 74 20 68 65 72 65 2e 20 49 74 20 ferent here. It
94b0: 69 73 20 61 20 6c 69 73 74 20 6f 66 20 63 6f 6d is a list of com
94c0: 6d 61 6e 64 73 20 74 6f 20 72 75 6e 2c 20 22 73 mands to run, "s
94d0: 63 72 69 70 74 6e 61 6d 65 20 3d 20 65 78 74 72 criptname = extr
94e0: 61 5f 70 61 72 61 6d 65 74 65 72 73 3b 73 63 72 a_parameters;scr
94f0: 69 70 74 6e 61 6d 65 20 3d 20 2e 2e 2e 22 0a 09 iptname = ..."..
9500: 09 20 20 20 20 20 20 3b 3b 20 77 68 65 72 65 20 . ;; where
9510: 73 63 72 69 70 74 6e 61 6d 65 20 6d 61 79 20 62 scriptname may b
9520: 65 20 72 65 70 65 61 74 65 64 20 6d 75 6c 74 69 e repeated multi
9530: 70 6c 65 20 74 69 6d 65 73 2e 20 54 68 65 20 73 ple times. The s
9540: 63 72 69 70 74 20 6d 75 73 74 20 72 65 74 75 72 cript must retur
9550: 6e 20 75 6e 69 78 2d 65 70 6f 63 68 20 6f 66 20 n unix-epoch of
9560: 6c 61 73 74 20 63 68 61 6e 67 65 2c 20 6e 65 77 last change, new
9570: 2d 74 61 72 67 65 74 2d 6e 61 6d 65 20 61 6e 64 -target-name and
9580: 20 6e 65 77 2d 72 75 6e 2d 6e 61 6d 65 0a 09 09 new-run-name...
9590: 20 20 20 20 20 20 3b 3b 20 74 68 65 20 73 63 72 ;; the scr
95a0: 69 70 74 20 69 73 20 63 61 6c 6c 65 64 20 6c 69 ipt is called li
95b0: 6b 65 20 74 68 69 73 3a 20 20 73 63 72 69 70 74 ke this: script
95c0: 6e 61 6d 65 20 63 6f 6e 74 6f 75 72 20 72 75 6e name contour run
95d0: 6b 65 79 20 73 74 64 2d 72 75 6e 6e 61 6d 65 20 key std-runname
95e0: 61 63 74 69 6f 6e 20 65 78 74 72 61 5f 70 61 72 action extra_par
95f0: 61 6d 31 20 65 78 74 72 61 5f 70 61 72 61 6d 32 am1 extra_param2
9600: 20 2e 2e 2e 0a 09 09 20 20 20 20 20 20 28 66 6f ...... (fo
9610: 72 2d 65 61 63 68 0a 09 09 20 20 20 20 20 20 20 r-each...
9620: 28 6c 61 6d 62 64 61 20 28 63 6d 64 29 0a 09 09 (lambda (cmd)...
9630: 09 20 28 70 72 69 6e 74 20 22 63 6d 64 3a 20 22 . (print "cmd: "
9640: 20 63 6d 64 29 0a 09 09 09 20 28 6c 65 74 2a 20 cmd).... (let*
9650: 28 28 73 63 72 69 70 74 20 28 63 61 72 20 63 6d ((script (car cm
9660: 64 29 29 0a 09 09 09 09 28 70 61 72 61 6d 73 20 d)).....(params
9670: 28 63 64 72 20 63 6d 64 29 29 0a 09 09 09 09 28 (cdr cmd)).....(
9680: 63 6d 64 20 20 20 20 28 63 6f 6e 63 20 73 63 72 cmd (conc scr
9690: 69 70 74 20 22 20 22 20 63 6f 6e 74 6f 75 72 20 ipt " " contour
96a0: 22 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 73 " " runkey " " s
96b0: 74 64 2d 72 75 6e 6e 61 6d 65 20 22 20 22 20 61 td-runname " " a
96c0: 63 74 69 6f 6e 20 22 20 22 20 70 61 72 61 6d 73 ction " " params
96d0: 29 29 0a 09 09 09 09 28 72 65 73 20 20 20 20 28 )).....(res (
96e0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
96f0: 73 0a 09 09 09 09 09 20 20 20 20 65 78 6e 0a 09 s...... exn..
9700: 09 09 09 09 20 20 20 20 23 66 0a 09 09 09 09 09 .... #f......
9710: 20 20 28 70 72 69 6e 74 20 22 52 75 6e 6e 69 6e (print "Runnin
9720: 67 20 22 20 63 6d 64 29 0a 09 09 09 09 09 20 20 g " cmd)......
9730: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
9740: 2d 70 69 70 65 20 63 6d 64 20 72 65 61 64 2d 6c -pipe cmd read-l
9750: 69 6e 65 73 29 29 29 29 0a 09 09 09 20 20 20 28 ines)))).... (
9760: 69 66 20 28 61 6e 64 20 72 65 73 20 28 6e 6f 74 if (and res (not
9770: 20 28 6e 75 6c 6c 3f 20 72 65 73 29 29 29 0a 09 (null? res)))..
9780: 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 .. (let* (
9790: 28 70 61 72 74 73 20 20 20 20 20 20 20 28 73 74 (parts (st
97a0: 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 61 72 20 ring-split (car
97b0: 72 65 73 29 29 29 20 3b 3b 0a 09 09 09 09 20 20 res))) ;;.....
97c0: 20 20 20 20 28 72 65 6d 2d 6c 69 6e 65 73 20 20 (rem-lines
97d0: 20 28 63 64 72 20 72 65 73 29 29 0a 09 09 09 09 (cdr res)).....
97e0: 20 20 20 20 20 20 28 6e 75 6d 2d 70 61 72 74 73 (num-parts
97f0: 20 20 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 (length parts
9800: 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 6c 61 ))..... (la
9810: 73 74 2d 63 68 61 6e 67 65 20 28 73 74 72 69 6e st-change (strin
9820: 67 2d 3e 6e 75 6d 62 65 72 20 28 69 66 20 28 3e g->number (if (>
9830: 20 6e 75 6d 2d 70 61 72 74 73 20 30 29 28 63 61 num-parts 0)(ca
9840: 72 20 70 61 72 74 73 29 20 22 61 62 63 22 29 29 r parts) "abc"))
9850: 29 20 20 3b 3b 20 66 6f 72 63 65 20 6e 6f 20 72 ) ;; force no r
9860: 75 6e 20 69 66 20 6e 6f 74 20 61 20 6e 75 6d 62 un if not a numb
9870: 65 72 20 72 65 74 75 72 6e 65 64 0a 09 09 09 09 er returned.....
9880: 20 20 20 20 20 20 28 6e 65 77 2d 74 61 72 67 65 (new-targe
9890: 74 20 20 28 69 66 20 28 3e 20 6e 75 6d 2d 70 61 t (if (> num-pa
98a0: 72 74 73 20 31 29 0a 09 09 09 09 09 09 20 20 20 rts 1).......
98b0: 20 20 20 20 28 63 61 64 72 20 70 61 72 74 73 29 (cadr parts)
98c0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 72 75 ....... ru
98d0: 6e 6b 65 79 29 29 0a 09 09 09 09 20 20 20 20 20 nkey)).....
98e0: 20 28 6e 65 77 2d 72 75 6e 6e 61 6d 65 20 28 69 (new-runname (i
98f0: 66 20 28 3e 20 6e 75 6d 2d 70 61 72 74 73 20 32 f (> num-parts 2
9900: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 )....... (
9910: 63 61 64 64 72 20 70 61 72 74 73 29 0a 09 09 09 caddr parts)....
9920: 09 09 09 20 20 20 20 20 20 20 73 74 64 2d 72 75 ... std-ru
9930: 6e 6e 61 6d 65 29 29 0a 09 09 09 09 20 20 20 20 nname)).....
9940: 20 20 28 6d 65 73 73 61 67 65 20 20 20 20 20 28 (message (
9950: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 2d 6c 69 if (null? rem-li
9960: 6e 65 73 29 0a 09 09 09 09 09 09 20 20 20 20 20 nes).......
9970: 20 20 63 6d 64 0a 09 09 09 09 09 09 20 20 20 20 cmd.......
9980: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
9990: 73 70 65 72 73 65 20 72 65 6d 2d 6c 69 6e 65 73 sperse rem-lines
99a0: 20 22 2d 22 29 29 29 0a 09 09 09 09 20 20 20 20 "-"))).....
99b0: 20 20 28 6e 65 65 64 2d 72 75 6e 20 20 20 20 28 (need-run (
99c0: 3e 20 6c 61 73 74 2d 63 68 61 6e 67 65 20 6c 61 > last-change la
99d0: 73 74 2d 72 75 6e 29 29 29 0a 09 09 09 09 20 28 st-run)))..... (
99e0: 70 72 69 6e 74 20 22 6c 61 73 74 2d 72 75 6e 3a print "last-run:
99f0: 20 22 20 6c 61 73 74 2d 72 75 6e 20 22 20 6e 65 " last-run " ne
9a00: 65 64 2d 72 75 6e 3a 20 22 20 6e 65 65 64 2d 72 ed-run: " need-r
9a10: 75 6e 29 0a 09 09 09 09 20 28 69 66 20 6e 65 65 un)..... (if nee
9a20: 64 2d 72 75 6e 0a 09 09 09 09 20 20 20 20 20 28 d-run..... (
9a30: 6c 65 74 2a 20 28 28 6b 65 79 2d 6d 73 67 20 20 let* ((key-msg
9a40: 20 20 60 28 28 6d 65 73 73 61 67 65 20 20 2e 20 `((message .
9a50: 2c 28 63 6f 6e 63 20 72 75 6c 65 74 79 70 65 20 ,(conc ruletype
9a60: 22 3a 22 20 6d 65 73 73 61 67 65 29 29 0a 09 09 ":" message))...
9a70: 09 09 09 09 09 20 20 28 72 75 6e 6e 61 6d 65 20 ..... (runname
9a80: 20 2e 20 2c 6e 65 77 2d 72 75 6e 6e 61 6d 65 29 . ,new-runname)
9a90: 0a 09 09 09 09 09 09 09 20 20 28 72 75 6e 74 72 ........ (runtr
9aa0: 61 6e 73 20 2e 20 2c 72 75 6e 74 72 61 6e 73 29 ans . ,runtrans)
9ab0: 0a 09 09 09 09 09 09 09 20 20 28 61 63 74 69 6f ........ (actio
9ac0: 6e 20 20 20 2e 20 2c 61 63 74 69 6f 6e 29 0a 09 n . ,action)..
9ad0: 09 09 09 09 09 09 20 20 28 61 72 65 61 73 20 20 ...... (areas
9ae0: 20 20 2e 20 2c 61 72 65 61 73 29 0a 09 09 09 09 . ,areas).....
9af0: 09 09 09 20 20 3b 3b 28 74 61 72 67 65 74 20 20 ... ;;(target
9b00: 20 2e 20 2c 28 6c 69 73 74 20 6e 65 77 2d 74 61 . ,(list new-ta
9b10: 72 67 65 74 29 29 20 3b 3b 20 6f 76 65 72 72 69 rget)) ;; overri
9b20: 64 69 6e 67 20 77 69 74 68 20 72 65 73 75 6c 74 ding with result
9b30: 20 66 72 6f 6d 20 72 75 6e 69 6e 67 20 74 68 65 from runing the
9b40: 20 73 63 72 69 70 74 0a 20 20 20 20 20 20 20 20 script.
9b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b80: 20 20 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 ))).....
9b90: 20 28 70 72 69 6e 74 20 22 6b 65 79 2d 6d 73 67 (print "key-msg
9ba0: 3a 20 22 20 6b 65 79 2d 6d 73 67 29 0a 09 09 09 : " key-msg)....
9bb0: 09 20 20 20 20 20 20 20 28 70 75 73 68 2d 72 75 . (push-ru
9bc0: 6e 2d 73 70 65 63 20 74 6f 72 75 6e 20 63 6f 6e n-spec torun con
9bd0: 74 6f 75 72 0a 09 09 09 09 09 09 20 20 20 20 20 tour.......
9be0: 20 28 69 66 20 6f 70 74 69 6f 6e 61 6c 20 20 3b (if optional ;
9bf0: 3b 20 77 65 20 6e 65 65 64 20 74 6f 20 62 65 20 ; we need to be
9c00: 61 62 6c 65 20 74 6f 20 64 69 66 66 65 72 65 6e able to differen
9c10: 74 69 61 74 65 20 73 61 6d 65 20 63 6f 6e 74 6f tiate same conto
9c20: 75 72 2c 20 64 69 66 66 65 72 65 6e 74 20 62 65 ur, different be
9c30: 68 61 76 69 6f 72 2e 20 0a 09 09 09 09 09 09 09 havior. ........
9c40: 20 20 28 63 6f 6e 63 20 72 75 6e 6b 65 79 20 22 (conc runkey "
9c50: 3a 22 20 6f 70 74 69 6f 6e 61 6c 29 20 20 3b 3b :" optional) ;;
9c60: 20 4e 4f 54 45 3a 20 4e 4f 54 20 43 4f 4d 50 4c NOTE: NOT COMPL
9c70: 45 54 45 4c 59 20 49 4d 50 4c 45 4d 45 4e 54 45 ETELY IMPLEMENTE
9c80: 44 2e 20 44 4f 20 4e 4f 54 20 55 53 45 0a 09 09 D. DO NOT USE...
9c90: 09 09 09 09 09 20 20 72 75 6e 6b 65 79 29 0a 09 ..... runkey)..
9ca0: 09 09 09 09 09 20 20 20 20 20 20 6b 65 79 2d 6d ..... key-m
9cb0: 73 67 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 sg)))))))...
9cc0: 20 20 20 76 61 6c 2d 61 6c 69 73 74 29 29 20 3b val-alist)) ;
9cd0: 3b 20 69 74 65 72 61 74 65 20 6f 76 65 72 20 74 ; iterate over t
9ce0: 68 65 20 70 61 72 61 6d 20 73 70 6c 69 74 20 62 he param split b
9cf0: 79 20 3b 5c 73 2a 0a 0a 09 09 20 20 20 20 20 3b y ;\s*.... ;
9d00: 3b 20 73 63 72 69 70 74 20 62 61 73 65 64 20 73 ; script based s
9d10: 65 6e 73 6f 72 73 0a 09 09 20 20 20 20 20 3b 3b ensors... ;;
9d20: 0a 09 09 20 20 20 20 20 28 28 61 72 65 61 2d 73 ... ((area-s
9d30: 63 72 69 70 74 29 0a 09 09 20 20 20 20 20 20 3b cript)... ;
9d40: 3b 20 73 79 6e 74 61 78 20 69 73 20 61 20 6c 69 ; syntax is a li
9d50: 74 74 6c 65 20 64 69 66 66 65 72 65 6e 74 20 68 ttle different h
9d60: 65 72 65 2e 20 49 74 20 69 73 20 61 20 6c 69 73 ere. It is a lis
9d70: 74 20 6f 66 20 63 6f 6d 6d 61 6e 64 73 20 74 6f t of commands to
9d80: 20 72 75 6e 2c 20 22 73 63 72 69 70 74 6e 61 6d run, "scriptnam
9d90: 65 20 3d 20 65 78 74 72 61 5f 70 61 72 61 6d 65 e = extra_parame
9da0: 74 65 72 73 3b 73 63 72 69 70 74 6e 61 6d 65 20 ters;scriptname
9db0: 3d 20 2e 2e 2e 22 0a 09 09 20 20 20 20 20 20 3b = ..."... ;
9dc0: 3b 20 77 68 65 72 65 20 73 63 72 69 70 74 6e 61 ; where scriptna
9dd0: 6d 65 20 6d 61 79 20 62 65 20 72 65 70 65 61 74 me may be repeat
9de0: 65 64 20 6d 75 6c 74 69 70 6c 65 20 74 69 6d 65 ed multiple time
9df0: 73 2e 20 54 68 65 20 73 63 72 69 70 74 20 6d 75 s. The script mu
9e00: 73 74 20 72 65 74 75 72 6e 20 75 6e 69 78 2d 65 st return unix-e
9e10: 70 6f 63 68 20 6f 66 20 6c 61 73 74 20 63 68 61 poch of last cha
9e20: 6e 67 65 2c 20 6e 65 77 2d 74 61 72 67 65 74 2d nge, new-target-
9e30: 6e 61 6d 65 20 61 6e 64 20 6e 65 77 2d 72 75 6e name and new-run
9e40: 2d 6e 61 6d 65 0a 09 09 20 20 20 20 20 20 3b 3b -name... ;;
9e50: 20 74 68 65 20 73 63 72 69 70 74 20 69 73 20 63 the script is c
9e60: 61 6c 6c 65 64 20 6c 69 6b 65 20 74 68 69 73 3a alled like this:
9e70: 20 20 73 63 72 69 70 74 6e 61 6d 65 20 63 6f 6e scriptname con
9e80: 74 6f 75 72 20 72 75 6e 6b 65 79 20 73 74 64 2d tour runkey std-
9e90: 72 75 6e 6e 61 6d 65 20 61 63 74 69 6f 6e 20 65 runname action e
9ea0: 78 74 72 61 5f 70 61 72 61 6d 31 20 65 78 74 72 xtra_param1 extr
9eb0: 61 5f 70 61 72 61 6d 32 20 2e 2e 2e 0a 09 09 20 a_param2 ......
9ec0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 (for-each..
9ed0: 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
9ee0: 28 63 6d 64 29 0a 09 09 09 20 3b 3b 28 70 72 69 (cmd).... ;;(pri
9ef0: 6e 74 20 22 63 6d 64 3a 20 22 20 63 6d 64 29 0a nt "cmd: " cmd).
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f10: 20 20 20 20 20 20 20 20 20 3b 3b 28 70 72 69 6e ;;(prin
9f20: 74 20 22 41 72 65 61 73 3a 20 22 20 61 6c 6c 2d t "Areas: " all-
9f30: 61 72 65 61 73 29 0a 20 20 20 20 20 20 20 20 20 areas).
9f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f50: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
9f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f70: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 (lambda (a
9f80: 72 65 61 29 20 0a 20 20 20 20 20 20 20 20 20 20 rea) .
9f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fa0: 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 41 72 65 ;;(print "Are
9fb0: 61 3a 20 22 20 61 72 65 61 29 0a 20 20 20 20 20 a: " area).
9fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fd0: 20 20 20 20 20 20 20 20 3b 3b 28 70 72 69 6e 74 ;;(print
9fe0: 20 22 54 61 72 67 65 74 3a 20 22 20 72 75 6e 6b "Target: " runk
9ff0: 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ey).
a000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a010: 20 3b 3b 28 70 72 69 6e 74 20 22 4f 52 3a 20 22 ;;(print "OR: "
a020: 20 28 6f 72 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (or (string->nu
a030: 6d 62 65 72 20 28 69 66 20 28 63 6f 6e 66 69 67 mber (if (config
a040: 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 f:lookup mtconf
a050: 22 73 65 74 75 70 22 20 22 6d 61 78 5f 70 61 63 "setup" "max_pac
a060: 6b 65 74 73 5f 70 65 72 5f 72 75 6e 22 29 20 28 kets_per_run") (
a070: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d configf:lookup m
a080: 74 63 6f 6e 66 20 22 73 65 74 75 70 22 20 22 6d tconf "setup" "m
a090: 61 78 5f 70 61 63 6b 65 74 73 5f 70 65 72 5f 72 ax_packets_per_r
a0a0: 75 6e 22 29 20 22 31 30 30 30 30 22 20 29 29 29 un") "10000" )))
a0b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
a0d0: 3b 28 70 72 69 6e 74 20 22 50 61 63 6b 65 74 73 ;(print "Packets
a0e0: 20 67 65 6e 65 72 61 74 65 64 3a 20 22 20 70 61 generated: " pa
a0f0: 63 6b 65 74 73 2d 67 65 6e 65 72 61 74 65 64 29 ckets-generated)
a100: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
a120: 28 70 72 69 6e 74 20 22 43 6f 6d 70 61 72 69 73 (print "Comparis
a130: 6f 6e 3a 20 22 20 28 3c 20 70 61 63 6b 65 74 73 on: " (< packets
a140: 2d 67 65 6e 65 72 61 74 65 64 20 34 29 29 0a 20 -generated 4)).
a150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a160: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 70 ;;(p
a170: 72 69 6e 74 20 22 46 75 6c 6c 20 43 6f 6d 70 61 rint "Full Compa
a180: 72 69 73 6f 6e 3a 20 22 20 0a 20 20 20 20 20 20 rison: " .
a190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1a0: 20 20 20 20 20 20 20 3b 3b 20 20 20 28 61 6e 64 ;; (and
a1b0: 20 28 3c 20 70 61 63 6b 65 74 73 2d 67 65 6e 65 (< packets-gene
a1c0: 72 61 74 65 64 20 28 6f 72 20 28 73 74 72 69 6e rated (or (strin
a1d0: 67 2d 3e 6e 75 6d 62 65 72 20 28 69 66 20 28 63 g->number (if (c
a1e0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 onfigf:lookup mt
a1f0: 63 6f 6e 66 20 22 73 65 74 75 70 22 20 22 6d 61 conf "setup" "ma
a200: 78 5f 70 61 63 6b 65 74 73 5f 70 65 72 5f 72 75 x_packets_per_ru
a210: 6e 22 29 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f n") (configf:loo
a220: 6b 75 70 20 6d 74 63 6f 6e 66 20 22 73 65 74 75 kup mtconf "setu
a230: 70 22 20 22 6d 61 78 5f 70 61 63 6b 65 74 73 5f p" "max_packets_
a240: 70 65 72 5f 72 75 6e 22 29 20 22 31 30 30 30 30 per_run") "10000
a250: 22 20 29 29 20 31 30 30 30 30 29 29 20 20 0a 20 " )) 10000)) .
a260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a270: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
a280: 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a (if (args:
a290: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
a2a0: 22 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 ") .
a2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2c0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
a2d0: 28 69 66 20 28 73 74 72 69 6e 67 3d 20 28 61 72 (if (string= (ar
a2e0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
a2f0: 67 65 74 22 29 20 72 75 6e 6b 65 79 29 20 28 61 get") runkey) (a
a300: 72 65 61 2d 61 6c 6c 6f 77 65 64 3f 20 61 72 65 rea-allowed? are
a310: 61 20 22 61 72 65 61 2d 6e 65 65 64 73 2d 74 6f a "area-needs-to
a320: 2d 62 65 2d 72 75 6e 22 20 72 75 6e 6b 65 79 20 -be-run" runkey
a330: 63 6f 6e 74 6f 75 72 20 23 66 29 20 23 66 29 20 contour #f) #f)
a340: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
a360: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 (ar
a370: 65 61 2d 61 6c 6c 6f 77 65 64 3f 20 61 72 65 61 ea-allowed? area
a380: 20 22 61 72 65 61 2d 6e 65 65 64 73 2d 74 6f 2d "area-needs-to-
a390: 62 65 2d 72 75 6e 22 20 72 75 6e 6b 65 79 20 63 be-run" runkey c
a3a0: 6f 6e 74 6f 75 72 20 23 66 29 29 29 29 0a 09 09 ontour #f))))...
a3b0: 09 20 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 41 . ;;(print "A
a3c0: 72 65 61 20 41 6c 6c 6f 77 65 64 3a 20 22 20 28 rea Allowed: " (
a3d0: 61 72 65 61 2d 61 6c 6c 6f 77 65 64 3f 20 61 72 area-allowed? ar
a3e0: 65 61 20 22 61 72 65 61 2d 6e 65 65 64 73 2d 74 ea "area-needs-t
a3f0: 6f 2d 62 65 2d 72 75 6e 22 20 72 75 6e 6b 65 79 o-be-run" runkey
a400: 20 63 6f 6e 74 6f 75 72 20 23 66 29 29 0a 3b 41 contour #f)).;A
a410: 64 64 20 63 6f 64 65 20 74 6f 20 63 68 65 63 6b dd code to check
a420: 20 77 68 65 74 68 65 72 20 61 72 65 61 20 69 73 whether area is
a430: 20 76 61 6c 69 64 0a 09 09 09 20 20 20 20 20 28 valid.... (
a440: 69 66 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 if .
a450: 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 63 ;; This c
a460: 6f 64 65 20 63 68 65 63 6b 73 20 77 68 65 74 68 ode checks wheth
a470: 65 72 20 74 68 65 20 74 61 72 67 65 74 20 68 61 er the target ha
a480: 73 20 62 65 65 6e 20 70 61 73 73 65 64 20 69 6e s been passed in
a490: 20 76 69 61 20 61 72 67 75 6d 65 6e 74 2c 20 61 via argument, a
a4a0: 6e 64 20 6f 6e 6c 79 20 72 75 6e 73 20 74 68 65 nd only runs the
a4b0: 20 73 70 65 63 69 66 69 65 64 20 74 61 72 67 65 specified targe
a4c0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
a4d0: 20 20 20 20 20 28 61 6e 64 20 28 3c 20 70 61 63 (and (< pac
a4e0: 6b 65 74 73 2d 67 65 6e 65 72 61 74 65 64 20 28 kets-generated (
a4f0: 6f 72 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 or (string->numb
a500: 65 72 20 28 69 66 20 28 63 6f 6e 66 69 67 66 3a er (if (configf:
a510: 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 73 lookup mtconf "s
a520: 65 74 75 70 22 20 22 6d 61 78 5f 70 61 63 6b 65 etup" "max_packe
a530: 74 73 5f 70 65 72 5f 72 75 6e 22 29 20 28 63 6f ts_per_run") (co
a540: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 nfigf:lookup mtc
a550: 6f 6e 66 20 22 73 65 74 75 70 22 20 22 6d 61 78 onf "setup" "max
a560: 5f 70 61 63 6b 65 74 73 5f 70 65 72 5f 72 75 6e _packets_per_run
a570: 22 29 20 22 31 30 30 30 30 22 20 29 29 20 31 30 ") "10000" )) 10
a580: 30 30 30 29 29 20 20 0a 20 20 20 20 20 20 20 20 000)) .
a590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5a0: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
a5b0: 67 20 22 2d 74 61 72 67 65 74 22 29 20 0a 20 20 g "-target") .
a5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 73 (if (s
a5e0: 74 72 69 6e 67 3d 20 28 61 72 67 73 3a 67 65 74 tring= (args:get
a5f0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 20 -arg "-target")
a600: 72 75 6e 6b 65 79 29 20 28 61 72 65 61 2d 61 6c runkey) (area-al
a610: 6c 6f 77 65 64 3f 20 61 72 65 61 20 22 61 72 65 lowed? area "are
a620: 61 2d 6e 65 65 64 73 2d 74 6f 2d 62 65 2d 72 75 a-needs-to-be-ru
a630: 6e 22 20 72 75 6e 6b 65 79 20 63 6f 6e 74 6f 75 n" runkey contou
a640: 72 20 23 66 29 20 23 66 29 20 0a 20 20 20 20 20 r #f) #f) .
a650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a660: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 65 61 (area
a670: 2d 61 6c 6c 6f 77 65 64 3f 20 61 72 65 61 20 22 -allowed? area "
a680: 61 72 65 61 2d 6e 65 65 64 73 2d 74 6f 2d 62 65 area-needs-to-be
a690: 2d 72 75 6e 22 20 72 75 6e 6b 65 79 20 63 6f 6e -run" runkey con
a6a0: 74 6f 75 72 20 23 66 29 29 29 0a 20 20 20 20 20 tour #f))).
a6b0: 20 20 0a 09 09 09 20 20 20 20 20 28 6c 65 74 2a .... (let*
a6c0: 20 28 28 73 63 72 69 70 74 20 28 63 61 72 20 63 ((script (car c
a6d0: 6d 64 29 29 0a 09 09 09 09 28 70 61 72 61 6d 73 md)).....(params
a6e0: 20 28 63 64 72 20 63 6d 64 29 29 0a 09 09 09 09 (cdr cmd)).....
a6f0: 28 63 6d 64 20 20 20 20 28 63 6f 6e 63 20 73 63 (cmd (conc sc
a700: 72 69 70 74 20 22 20 22 20 63 6f 6e 74 6f 75 72 ript " " contour
a710: 20 22 20 22 20 61 72 65 61 20 22 20 22 20 72 75 " " area " " ru
a720: 6e 6b 65 79 20 22 20 22 20 73 74 64 2d 72 75 6e nkey " " std-run
a730: 6e 61 6d 65 20 22 20 22 20 61 63 74 69 6f 6e 20 name " " action
a740: 22 20 22 20 70 61 72 61 6d 73 29 29 0a 09 09 09 " " params))....
a750: 09 28 72 65 73 20 20 20 20 28 68 61 6e 64 6c 65 .(res (handle
a760: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 -exceptions.....
a770: 09 20 20 20 20 65 78 6e 0a 09 09 09 09 09 20 20 . exn......
a780: 20 20 23 66 0a 09 09 09 09 09 20 20 28 70 72 69 #f...... (pri
a790: 6e 74 20 22 52 75 6e 6e 69 6e 67 20 22 20 63 6d nt "Running " cm
a7a0: 64 29 0a 09 09 09 09 09 20 20 28 77 69 74 68 2d d)...... (with-
a7b0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
a7c0: 63 6d 64 20 72 65 61 64 2d 6c 69 6e 65 73 29 29 cmd read-lines))
a7d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7f0: 20 20 28 63 76 61 6c 20 20 20 20 20 20 20 28 6f (cval (o
a800: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
a810: 70 20 6d 74 63 6f 6e 66 20 22 63 6f 6e 74 6f 75 p mtconf "contou
a820: 72 73 22 20 63 6f 6e 74 6f 75 72 29 20 22 22 29 rs" contour) "")
a830: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a850: 20 20 28 63 76 61 6c 2d 61 6c 69 73 74 20 28 63 (cval-alist (c
a860: 6f 6d 6d 6f 6e 3a 76 61 6c 2d 3e 61 6c 69 73 74 ommon:val->alist
a870: 20 63 76 61 6c 29 29 20 20 20 20 20 20 20 20 20 cval))
a880: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 42 ;; B
a890: 45 57 41 52 45 20 2e 2e 2e 20 4e 4f 54 20 74 68 EWARE ... NOT th
a8a0: 65 20 73 61 6d 65 20 76 61 6c 2d 61 6c 69 73 74 e same val-alist
a8b0: 20 61 73 20 61 62 6f 76 65 21 0a 20 20 20 20 20 as above!.
a8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a8d0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 61 72 ;;(ar
a8e0: 65 61 73 20 20 20 20 20 20 28 76 61 6c 2d 61 6c eas (val-al
a8f0: 69 73 74 2d 3e 61 72 65 61 73 20 63 76 61 6c 2d ist->areas cval-
a900: 61 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 alist)).
a910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a920: 20 20 20 20 20 20 20 20 28 73 65 6c 65 63 74 6f (selecto
a930: 72 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 r (alist-ref '
a940: 73 65 6c 65 63 74 6f 72 20 63 76 61 6c 2d 61 6c selector cval-al
a950: 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ist)).
a960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a970: 20 20 20 20 20 20 28 6d 6f 64 65 2d 74 61 67 20 (mode-tag
a980: 20 20 28 61 6e 64 20 73 65 6c 65 63 74 6f 72 20 (and selector
a990: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 (string-split-fi
a9a0: 65 6c 64 73 20 22 2f 22 20 73 65 6c 65 63 74 6f elds "/" selecto
a9b0: 72 20 23 3a 69 6e 66 69 78 29 29 29 0a 20 20 20 r #:infix))).
a9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 6f (mo
a9e0: 64 65 2d 70 61 74 74 20 20 28 61 6e 64 20 6d 6f de-patt (and mo
a9f0: 64 65 2d 74 61 67 20 28 69 66 20 28 65 71 3f 20 de-tag (if (eq?
aa00: 28 6c 65 6e 67 74 68 20 6d 6f 64 65 2d 74 61 67 (length mode-tag
aa10: 29 20 32 29 28 63 61 64 72 20 6d 6f 64 65 2d 74 ) 2)(cadr mode-t
aa20: 61 67 29 20 23 66 29 29 29 0a 20 20 20 20 20 20 ag) #f))).
aa30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa40: 20 20 20 20 20 20 20 20 20 20 28 74 61 67 2d 65 (tag-e
aa50: 78 70 72 20 20 20 28 61 6e 64 20 6d 6f 64 65 2d xpr (and mode-
aa60: 74 61 67 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6d tag (if (null? m
aa70: 6f 64 65 2d 74 61 67 29 20 23 66 20 28 63 61 72 ode-tag) #f (car
aa80: 20 6d 6f 64 65 2d 74 61 67 29 29 29 29 0a 20 20 mode-tag)))).
aa90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aaa0: 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 09 09 )...
aab0: 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 . (if (and r
aac0: 65 73 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 es (not (null? r
aad0: 65 73 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 es)))....
aae0: 28 6c 65 74 2a 20 28 28 70 61 72 74 73 20 20 20 (let* ((parts
aaf0: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 (string-spli
ab00: 74 20 28 63 61 72 20 72 65 73 29 29 29 20 3b 3b t (car res))) ;;
ab10: 0a 09 09 09 09 20 20 20 20 20 20 28 72 65 6d 2d ..... (rem-
ab20: 6c 69 6e 65 73 20 20 20 28 63 64 72 20 72 65 73 lines (cdr res
ab30: 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 6e 75 ))..... (nu
ab40: 6d 2d 70 61 72 74 73 20 20 20 28 6c 65 6e 67 74 m-parts (lengt
ab50: 68 20 70 61 72 74 73 29 29 0a 09 09 09 09 20 20 h parts)).....
ab60: 20 20 20 20 28 6c 61 73 74 2d 63 68 61 6e 67 65 (last-change
ab70: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
ab80: 20 28 69 66 20 28 3e 20 6e 75 6d 2d 70 61 72 74 (if (> num-part
ab90: 73 20 30 29 28 63 61 72 20 70 61 72 74 73 29 20 s 0)(car parts)
aba0: 22 61 62 63 22 29 29 29 20 20 3b 3b 20 66 6f 72 "abc"))) ;; for
abb0: 63 65 20 6e 6f 20 72 75 6e 20 69 66 20 6e 6f 74 ce no run if not
abc0: 20 61 20 6e 75 6d 62 65 72 20 72 65 74 75 72 6e a number return
abd0: 65 64 0a 09 09 09 09 20 20 20 20 20 20 28 6e 65 ed..... (ne
abe0: 77 2d 74 61 72 67 65 74 20 20 28 69 66 20 28 3e w-target (if (>
abf0: 20 6e 75 6d 2d 70 61 72 74 73 20 31 29 0a 09 09 num-parts 1)...
ac00: 09 09 09 09 20 20 20 20 20 20 20 28 63 61 64 72 .... (cadr
ac10: 20 70 61 72 74 73 29 0a 09 09 09 09 09 09 20 20 parts).......
ac20: 20 20 20 20 20 72 75 6e 6b 65 79 29 29 0a 09 09 runkey))...
ac30: 09 09 20 20 20 20 20 20 28 6e 65 77 2d 72 75 6e .. (new-run
ac40: 6e 61 6d 65 20 28 69 66 20 28 3e 20 6e 75 6d 2d name (if (> num-
ac50: 70 61 72 74 73 20 32 29 0a 09 09 09 09 09 09 20 parts 2).......
ac60: 20 20 20 20 20 20 28 63 61 64 64 72 20 70 61 72 (caddr par
ac70: 74 73 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 ts).......
ac80: 20 73 74 64 2d 72 75 6e 6e 61 6d 65 29 29 0a 20 std-runname)).
ac90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aca0: 20 20 20 20 20 20 20 09 20 20 20 20 20 20 28 61 . (a
acb0: 72 65 61 2d 70 6b 74 73 20 20 28 66 69 6e 64 2d rea-pkts (find-
acc0: 70 6b 74 73 20 70 64 62 20 27 28 72 75 6e 73 74 pkts pdb '(runst
acd0: 61 72 74 29 20 60 28 28 63 20 2e 20 2c 63 6f 6e art) `((c . ,con
ace0: 74 6f 75 72 29 0a 20 20 20 20 20 20 20 20 20 20 tour).
acf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad30: 20 20 20 20 20 28 74 20 2e 20 2c 72 75 6e 6b 65 (t . ,runke
ad40: 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 y).
ad50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad90: 20 20 28 47 20 2e 20 2c 61 72 65 61 20 29 29 29 (G . ,area )))
ada0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
adb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
adc0: 20 20 20 20 20 20 20 20 28 72 75 6e 73 74 61 72 (runstar
add0: 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ts (filter (lamb
ade0: 64 61 20 28 6d 79 2d 70 6b 74 29 0a 20 20 20 20 da (my-pkt).
adf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae10: 20 20 20 20 20 20 20 3b 3b 28 70 72 69 6e 74 20 ;;(print
ae20: 6d 79 2d 70 6b 74 29 0a 20 20 20 20 20 20 20 20 my-pkt).
ae30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae50: 20 20 20 28 6e 6f 74 20 28 63 6f 6e 74 61 69 6e (not (contain
ae60: 73 20 28 6d 61 70 0a 20 20 20 20 20 20 20 20 20 s (map.
ae70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae90: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 63 (lambda (c
aea0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
aeb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aed0: 20 20 3b 3b 28 70 72 69 6e 74 20 22 43 3a 20 22 ;;(print "C: "
aee0: 20 63 20 22 50 4b 54 3a 20 22 20 6d 79 2d 70 6b c "PKT: " my-pk
aef0: 74 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 t) .
af00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af20: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 74 79 70 (let* ((ctyp
af30: 65 20 28 63 61 72 20 63 29 29 0a 20 20 20 20 20 e (car c)).
af40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af70: 20 20 28 72 78 20 28 63 64 72 20 63 29 29 0a 20 (rx (cdr c)).
af80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afb0: 20 20 20 20 20 20 3b 3b 28 66 6f 6f 32 20 28 70 ;;(foo2 (p
afc0: 72 69 6e 74 20 22 43 74 79 70 65 3a 20 22 20 63 rint "Ctype: " c
afd0: 74 79 70 65 20 22 20 52 58 3a 20 22 20 72 78 29 type " RX: " rx)
afe0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
aff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b010: 20 20 20 20 20 20 20 20 20 28 70 6b 74 20 28 61 (pkt (a
b020: 6c 69 73 74 2d 72 65 66 20 27 70 6b 74 20 6d 79 list-ref 'pkt my
b030: 2d 70 6b 74 29 29 0a 20 20 20 20 20 20 20 20 20 -pkt)).
b040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
b070: 70 6b 74 20 28 70 6b 74 2d 3e 61 6c 69 73 74 20 pkt (pkt->alist
b080: 70 6b 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 pkt)).
b090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 (cd
b0c0: 61 74 20 28 61 6c 69 73 74 2d 72 65 66 20 63 74 at (alist-ref ct
b0d0: 79 70 65 20 61 70 6b 74 29 29 29 0a 20 20 20 20 ype apkt))).
b0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b100: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
b110: 20 72 78 0a 20 20 20 20 20 20 20 20 20 20 20 20 rx.
b120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b140: 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
b150: 2d 6d 61 74 63 68 20 22 74 22 20 28 73 79 6d 62 -match "t" (symb
b160: 6f 6c 2d 3e 73 74 72 69 6e 67 20 63 74 79 70 65 ol->string ctype
b170: 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ) ).
b180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b1a0: 20 20 20 20 20 28 62 65 67 69 6e 20 28 69 66 20 (begin (if
b1b0: 23 66 20 28 70 72 69 6e 74 20 22 52 58 3a 20 22 #f (print "RX: "
b1c0: 20 72 78 20 22 20 43 44 41 54 3a 20 22 20 28 73 rx " CDAT: " (s
b1d0: 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 tring-join (take
b1e0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 (string-split c
b1f0: 64 61 74 20 22 2f 22 29 20 33 29 20 22 2f 22 29 dat "/") 3) "/")
b200: 29 29 20 28 69 66 20 63 64 61 74 20 28 73 74 72 )) (if cdat (str
b210: 69 6e 67 2d 6d 61 74 63 68 20 72 78 20 28 73 74 ing-match rx (st
b220: 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 20 ring-join (take
b230: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 64 (string-split cd
b240: 61 74 20 22 2f 22 29 20 33 29 20 22 2f 22 29 29 at "/") 3) "/"))
b250: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
b260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b280: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 69 (begin (i
b290: 66 20 23 66 20 28 70 72 69 6e 74 20 22 52 58 3a f #f (print "RX:
b2a0: 20 22 20 72 78 20 22 20 43 44 41 54 3a 20 22 20 " rx " CDAT: "
b2b0: 63 64 61 74 29 29 20 28 69 66 20 63 64 61 74 20 cdat)) (if cdat
b2c0: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 78 (string-match rx
b2d0: 20 63 64 61 74 29 20 23 66 29 29 29 20 23 66 29 cdat) #f))) #f)
b2e0: 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
b2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b310: 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 )).
b320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 60 28 `(
b340: 28 63 20 2e 20 2c 63 6f 6e 74 6f 75 72 29 20 28 (c . ,contour) (
b350: 74 20 2e 20 2c 72 75 6e 6b 65 79 29 20 28 47 20 t . ,runkey) (G
b360: 2e 20 2c 61 72 65 61 29 29 29 20 23 66 29 29 29 . ,area))) #f)))
b370: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b390: 20 20 20 20 20 20 20 20 20 61 72 65 61 2d 70 6b area-pk
b3a0: 74 73 29 29 0a 0a 20 20 20 20 20 20 20 20 20 20 ts))..
b3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3c0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 74 ;;(t
b3d0: 65 73 74 20 28 70 70 20 72 75 6e 73 74 61 72 74 est (pp runstart
b3e0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
b3f0: 20 20 20 20 20 20 20 20 20 20 20 20 09 20 20 20 .
b400: 20 20 20 28 72 73 70 6b 74 73 20 20 20 20 20 28 (rspkts (
b410: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 2d 61 common:get-pkt-a
b420: 6c 69 73 74 73 20 72 75 6e 73 74 61 72 74 73 29 lists runstarts)
b430: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b440: 20 20 20 20 20 20 20 20 20 20 09 20 20 20 20 20 .
b450: 20 3b 3b 20 73 74 61 72 74 74 69 6d 65 73 20 69 ;; starttimes i
b460: 73 20 66 6f 72 20 72 75 6e 20 73 74 61 72 74 20 s for run start
b470: 74 69 6d 65 73 20 61 6e 64 20 69 73 20 75 73 65 times and is use
b480: 64 20 74 6f 20 6b 6e 6f 77 20 77 68 65 6e 20 74 d to know when t
b490: 68 65 20 6c 61 73 74 20 72 75 6e 20 77 61 73 20 he last run was
b4a0: 6c 61 75 6e 63 68 65 64 0a 20 20 20 20 20 20 20 launched.
b4b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4c0: 20 09 20 20 20 20 20 20 28 73 74 61 72 74 74 69 . (startti
b4d0: 6d 65 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d mes (common:get-
b4e0: 70 6b 74 2d 74 69 6d 65 73 20 72 73 70 6b 74 73 pkt-times rspkts
b4f0: 29 29 20 3b 3b 20 73 6f 72 74 20 62 79 20 61 67 )) ;; sort by ag
b500: 65 20 28 79 6f 75 6e 67 65 73 74 20 66 69 72 73 e (youngest firs
b510: 74 29 20 61 6e 64 20 64 65 6c 65 74 65 20 64 75 t) and delete du
b520: 70 6c 69 63 61 74 65 73 20 62 79 20 74 61 72 67 plicates by targ
b530: 65 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 et.
b540: 20 20 20 20 20 20 20 20 20 20 20 09 20 20 20 20 .
b550: 20 20 28 6c 61 73 74 2d 72 75 6e 20 20 20 28 69 (last-run (i
b560: 66 20 28 6e 75 6c 6c 3f 20 73 74 61 72 74 74 69 f (null? startti
b570: 6d 65 73 29 20 3b 3b 20 69 66 20 27 28 29 20 74 mes) ;; if '() t
b580: 68 65 6e 20 69 74 20 68 61 73 20 6e 65 76 65 72 hen it has never
b590: 20 62 65 65 6e 20 72 75 6e 2c 20 65 6c 73 65 20 been run, else
b5a0: 67 65 74 20 74 68 65 20 6d 61 78 0a 20 20 20 20 get the max.
b5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5d0: 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 20 20 0.
b5e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b600: 28 61 70 70 6c 79 20 6d 61 78 20 28 6d 61 70 20 (apply max (map
b610: 63 64 72 20 73 74 61 72 74 74 69 6d 65 73 29 29 cdr starttimes))
b620: 29 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))..
b630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b640: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 6c 61 73 ;; (las
b650: 74 2d 72 75 6e 20 20 39 29 20 3b 3b 20 49 20 74 t-run 9) ;; I t
b660: 68 69 6e 6b 20 77 65 20 63 61 6e 20 64 6f 20 61 hink we can do a
b670: 20 6d 6f 72 65 20 76 61 6c 69 64 20 63 61 6c 63 more valid calc
b680: 75 6c 61 74 69 6f 6e 20 66 6f 72 20 74 68 69 73 ulation for this
b690: 20 62 61 73 65 64 20 6f 6e 20 74 68 65 20 72 75 based on the ru
b6a0: 6e 20 73 74 61 72 74 65 64 20 70 61 63 6b 65 74 n started packet
b6b0: 73 20 66 6f 72 20 74 68 69 73 20 70 61 72 74 69 s for this parti
b6c0: 63 75 6c 61 72 20 61 72 65 61 20 61 6e 64 20 74 cular area and t
b6d0: 61 72 67 65 74 0a 20 20 20 20 20 20 20 20 20 20 arget.
b6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b6f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 61 (rea
b700: 73 6f 6e 20 22 41 72 65 61 2d 73 63 72 69 70 74 son "Area-script
b710: 2d 74 72 69 67 67 65 72 65 64 22 29 0a 20 20 20 -triggered").
b720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b740: 20 20 20 3b 3b 28 6d 6f 64 65 2d 70 61 74 74 20 ;;(mode-patt
b750: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f).
b760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b770: 20 20 20 20 20 20 20 20 20 20 3b 3b 28 74 61 67 ;;(tag
b780: 2d 65 78 70 72 20 23 66 29 0a 09 09 09 09 20 20 -expr #f).....
b790: 20 20 20 20 28 73 63 68 65 64 20 23 66 29 0a 09 (sched #f)..
b7a0: 09 09 09 20 20 20 20 20 20 28 6d 65 73 73 61 67 ... (messag
b7b0: 65 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f e (if (null?
b7c0: 20 72 65 6d 2d 6c 69 6e 65 73 29 0a 09 09 09 09 rem-lines).....
b7d0: 09 09 20 20 20 20 20 20 20 63 6d 64 0a 09 09 09 .. cmd....
b7e0: 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
b7f0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 65 g-intersperse re
b800: 6d 2d 6c 69 6e 65 73 20 22 2d 22 29 29 29 0a 09 m-lines "-")))..
b810: 09 09 09 20 20 20 20 20 20 28 6e 65 65 64 2d 72 ... (need-r
b820: 75 6e 20 20 20 20 28 3e 20 6c 61 73 74 2d 63 68 un (> last-ch
b830: 61 6e 67 65 20 6c 61 73 74 2d 72 75 6e 29 29 29 ange last-run)))
b840: 0a 09 09 09 09 20 28 70 72 69 6e 74 20 22 6c 61 ..... (print "la
b850: 73 74 2d 63 68 61 6e 67 65 3a 20 22 20 6c 61 73 st-change: " las
b860: 74 2d 63 68 61 6e 67 65 20 22 20 6c 61 73 74 2d t-change " last-
b870: 72 75 6e 3a 20 22 20 6c 61 73 74 2d 72 75 6e 20 run: " last-run
b880: 22 20 6e 65 65 64 2d 72 75 6e 3a 20 22 20 6e 65 " need-run: " ne
b890: 65 64 2d 72 75 6e 29 0a 09 09 09 09 20 28 69 66 ed-run)..... (if
b8a0: 20 6e 65 65 64 2d 72 75 6e 0a 09 09 09 09 20 20 need-run.....
b8b0: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 2d 6d (let* ((key-m
b8c0: 73 67 20 20 20 20 60 28 28 6d 65 73 73 61 67 65 sg `((message
b8d0: 20 20 2e 20 2c 28 63 6f 6e 63 20 72 75 6c 65 74 . ,(conc rulet
b8e0: 79 70 65 20 22 3a 22 20 6d 65 73 73 61 67 65 29 ype ":" message)
b8f0: 29 0a 09 09 09 09 09 09 09 20 20 28 72 75 6e 6e )........ (runn
b900: 61 6d 65 20 20 2e 20 2c 6e 65 77 2d 72 75 6e 6e ame . ,new-runn
b910: 61 6d 65 29 0a 09 09 09 09 09 09 09 20 20 28 72 ame)........ (r
b920: 75 6e 74 72 61 6e 73 20 2e 20 2c 72 75 6e 74 72 untrans . ,runtr
b930: 61 6e 73 29 0a 09 09 09 09 09 09 09 20 20 28 61 ans)........ (a
b940: 63 74 69 6f 6e 20 20 20 2e 20 2c 61 63 74 69 6f ction . ,actio
b950: 6e 29 0a 09 09 09 09 09 09 09 20 20 28 61 72 65 n)........ (are
b960: 61 73 20 20 20 20 2e 20 2c 61 72 65 61 29 0a 09 as . ,area)..
b970: 09 09 09 09 09 09 20 20 3b 3b 28 74 61 72 67 65 ...... ;;(targe
b980: 74 20 20 20 2e 20 2c 28 6c 69 73 74 20 6e 65 77 t . ,(list new
b990: 2d 74 61 72 67 65 74 29 29 20 3b 3b 20 6f 76 65 -target)) ;; ove
b9a0: 72 72 69 64 69 6e 67 20 77 69 74 68 20 72 65 73 rriding with res
b9b0: 75 6c 74 20 66 72 6f 6d 20 72 75 6e 69 6e 67 20 ult from runing
b9c0: 74 68 65 20 73 63 72 69 70 74 0a 20 20 20 20 20 the script.
b9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba00: 20 20 20 20 20 29 29 0a 09 09 09 09 09 09 09 28 ))........(
ba10: 61 76 61 6c 20 20 20 20 20 20 20 28 6f 72 20 28 aval (or (
ba20: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d configf:lookup m
ba30: 74 63 6f 6e 66 20 22 61 72 65 61 73 22 20 61 72 tconf "areas" ar
ba40: 65 61 29 20 22 22 29 29 0a 20 20 20 20 20 20 20 ea) "")).
ba50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba60: 20 20 20 20 20 20 20 20 20 20 20 20 20 09 09 09 ...
ba70: 28 61 76 61 6c 2d 61 6c 69 73 74 20 28 63 6f 6d (aval-alist (com
ba80: 6d 6f 6e 3a 76 61 6c 2d 3e 61 6c 69 73 74 20 61 mon:val->alist a
ba90: 76 61 6c 29 29 0a 0a 09 09 09 09 09 09 09 28 74 val)).........(t
baa0: 61 72 67 65 74 73 20 28 6d 61 70 2d 74 61 72 67 argets (map-targ
bab0: 65 74 73 20 6d 74 63 6f 6e 66 20 61 76 61 6c 2d ets mtconf aval-
bac0: 61 6c 69 73 74 20 72 75 6e 6b 65 79 20 61 72 65 alist runkey are
bad0: 61 20 63 6f 6e 74 6f 75 72 29 29 29 0a 20 20 20 a contour))).
bae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
baf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb00: 20 20 20 20 20 28 70 70 20 74 61 72 67 65 74 73 (pp targets
bb10: 29 0a 09 09 09 09 20 20 20 20 20 20 20 20 28 66 )..... (f
bb20: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
bb30: 28 74 61 72 67 65 74 29 20 0a 20 20 20 20 20 20 (target) .
bb40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
bb70: 63 72 65 61 74 65 2d 72 75 6e 2d 70 6b 74 20 6d create-run-pkt m
bb80: 74 63 6f 6e 66 20 61 63 74 69 6f 6e 20 61 72 65 tconf action are
bb90: 61 20 72 75 6e 6b 65 79 20 74 61 72 67 65 74 20 a runkey target
bba0: 6e 65 77 2d 72 75 6e 6e 61 6d 65 20 6d 6f 64 65 new-runname mode
bbb0: 2d 70 61 74 74 0a 20 20 20 20 20 20 20 20 20 20 -patt.
bbc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bbe0: 20 20 20 20 20 20 20 20 20 20 20 20 74 61 67 2d tag-
bbf0: 65 78 70 72 20 70 6b 74 73 64 69 72 20 72 65 61 expr pktsdir rea
bc00: 73 6f 6e 20 63 6f 6e 74 6f 75 72 20 73 63 68 65 son contour sche
bc10: 64 20 64 62 64 65 73 74 20 61 70 70 65 6e 64 0a d dbdest append.
bc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc50: 20 20 20 20 20 20 72 75 6e 74 72 61 6e 73 29 0a runtrans).
bc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc90: 20 20 20 20 20 28 73 65 74 21 20 70 61 63 6b 65 (set! packe
bca0: 74 73 2d 67 65 6e 65 72 61 74 65 64 20 28 2b 20 ts-generated (+
bcb0: 70 61 63 6b 65 74 73 2d 67 65 6e 65 72 61 74 65 packets-generate
bcc0: 64 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 d 1)).
bcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bcf0: 20 20 20 20 20 20 20 20 29 20 74 61 72 67 65 74 ) target
bd00: 73 29 0a 09 09 09 09 09 3b 3b 20 41 64 64 20 66 s)......;; Add f
bd10: 69 6c 74 65 72 20 66 6f 72 20 74 61 72 67 65 74 ilter for target
bd20: 73 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s..
bd30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd40: 20 20 20 20 20 20 20 20 20 20 3b 3b 28 63 72 65 ;;(cre
bd50: 61 74 65 2d 72 75 6e 2d 70 6b 74 20 6d 74 63 6f ate-run-pkt mtco
bd60: 6e 66 20 61 63 74 69 6f 6e 20 61 72 65 61 20 72 nf action area r
bd70: 75 6e 6b 65 79 20 74 61 72 67 65 74 20 72 75 6e unkey target run
bd80: 6e 61 6d 65 0a 20 20 20 20 20 20 20 20 20 20 20 name.
bd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bda0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
bdb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 70 6b 74 pkt
bdc0: 73 64 69 72 20 72 65 61 73 6f 6e 20 63 6f 6e 74 sdir reason cont
bdd0: 6f 75 72 20 64 62 64 65 73 74 20 61 70 70 65 6e our dbdest appen
bde0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
bdf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be00: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
be10: 20 20 20 20 20 20 20 20 20 20 72 75 6e 74 72 61 runtra
be20: 6e 73 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 ns)..... (
be30: 70 72 69 6e 74 20 22 6b 65 79 2d 6d 73 67 3a 20 print "key-msg:
be40: 22 20 6b 65 79 2d 6d 73 67 29 0a 09 09 09 09 20 " key-msg).....
be50: 20 20 20 20 20 20 3b 3b 28 70 75 73 68 2d 72 75 ;;(push-ru
be60: 6e 2d 73 70 65 63 20 74 6f 72 75 6e 20 63 6f 6e n-spec torun con
be70: 74 6f 75 72 0a 09 09 09 09 3b 3b 09 09 20 20 20 tour.....;;..
be80: 20 20 20 28 69 66 20 6f 70 74 69 6f 6e 61 6c 20 (if optional
be90: 20 3b 3b 20 77 65 20 6e 65 65 64 20 74 6f 20 62 ;; we need to b
bea0: 65 20 61 62 6c 65 20 74 6f 20 64 69 66 66 65 72 e able to differ
beb0: 65 6e 74 69 61 74 65 20 73 61 6d 65 20 63 6f 6e entiate same con
bec0: 74 6f 75 72 2c 20 64 69 66 66 65 72 65 6e 74 20 tour, different
bed0: 62 65 68 61 76 69 6f 72 2e 20 0a 09 09 09 09 3b behavior. .....;
bee0: 3b 09 09 09 20 20 28 63 6f 6e 63 20 72 75 6e 6b ;... (conc runk
bef0: 65 79 20 22 3a 22 20 6f 70 74 69 6f 6e 61 6c 29 ey ":" optional)
bf00: 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 4f 54 20 43 ;; NOTE: NOT C
bf10: 4f 4d 50 4c 45 54 45 4c 59 20 49 4d 50 4c 45 4d OMPLETELY IMPLEM
bf20: 45 4e 54 45 44 2e 20 44 4f 20 4e 4f 54 20 55 53 ENTED. DO NOT US
bf30: 45 0a 09 09 09 09 3b 3b 09 09 09 20 20 72 75 6e E.....;;... run
bf40: 6b 65 79 29 0a 09 09 09 09 3b 3b 09 09 20 20 20 key).....;;..
bf50: 20 20 20 6b 65 79 2d 6d 73 67 29 0a 20 20 20 20 key-msg).
bf60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf80: 20 20 20 29 29 29 29 29 20 0a 20 20 20 20 20 20 ))))) .
bf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfb0: 20 28 69 66 20 28 3e 3d 20 70 61 63 6b 65 74 73 (if (>= packets
bfc0: 2d 67 65 6e 65 72 61 74 65 64 20 28 73 74 72 69 -generated (stri
bfd0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 6f 6e 66 ng->number (conf
bfe0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e igf:lookup mtcon
bff0: 66 20 22 73 65 74 75 70 22 20 22 6d 61 78 5f 70 f "setup" "max_p
c000: 61 63 6b 65 74 73 5f 70 65 72 5f 72 75 6e 22 29 ackets_per_run")
c010: 29 29 20 28 70 72 69 6e 74 20 22 53 6b 69 70 70 )) (print "Skipp
c020: 69 6e 67 20 61 72 65 61 3a 20 22 20 61 72 65 61 ing area: " area
c030: 20 22 20 61 6e 64 20 74 61 72 67 65 74 3a 20 22 " and target: "
c040: 20 72 75 6e 6b 65 79 20 22 20 64 75 65 20 74 6f runkey " due to
c050: 20 70 61 63 6b 65 74 73 2d 67 65 6e 65 72 61 74 packets-generat
c060: 65 64 3a 20 22 20 70 61 63 6b 65 74 73 2d 67 65 ed: " packets-ge
c070: 6e 65 72 61 74 65 64 20 22 20 68 69 67 68 65 72 nerated " higher
c080: 20 74 68 61 6e 20 22 20 28 63 6f 6e 66 69 67 66 than " (configf
c090: 3a 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 :lookup mtconf "
c0a0: 73 65 74 75 70 22 20 22 6d 61 78 5f 70 61 63 6b setup" "max_pack
c0b0: 65 74 73 5f 70 65 72 5f 72 75 6e 22 29 29 29 29 ets_per_run"))))
c0c0: 20 20 20 20 0a 0a 20 20 20 20 20 20 20 20 20 20 ..
c0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 20 28 ) (
c0e0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
c0f0: 78 29 20 28 69 66 20 28 6e 6f 74 20 28 61 72 67 x) (if (not (arg
c100: 73 3a 67 65 74 2d 61 72 67 20 22 2d 61 72 65 61 s:get-arg "-area
c110: 22 29 29 20 23 74 20 28 69 66 20 28 73 74 72 69 ")) #t (if (stri
c120: 6e 67 3d 20 78 20 28 61 72 67 73 3a 67 65 74 2d ng= x (args:get-
c130: 61 72 67 20 22 2d 61 72 65 61 22 29 29 20 23 74 arg "-area")) #t
c140: 20 23 66 29 29 29 20 61 6c 6c 2d 61 72 65 61 73 #f))) all-areas
c150: 29 29 0a 09 09 20 20 20 20 20 20 20 29 20 76 61 ))... ) va
c160: 6c 2d 61 6c 69 73 74 29 29 20 3b 3b 20 69 74 65 l-alist)) ;; ite
c170: 72 61 74 65 20 6f 76 65 72 20 74 68 65 20 70 61 rate over the pa
c180: 72 61 6d 20 73 70 6c 69 74 20 62 79 20 3b 5c 73 ram split by ;\s
c190: 2a 0a 0a 09 09 20 20 20 20 20 3b 3b 20 66 6f 73 *.... ;; fos
c1a0: 73 69 6c 20 73 63 6d 20 62 61 73 65 64 20 74 72 sil scm based tr
c1b0: 69 67 67 65 72 73 0a 09 09 20 20 20 20 20 3b 3b iggers... ;;
c1c0: 0a 09 09 20 20 20 20 20 28 28 66 6f 73 73 69 6c ... ((fossil
c1d0: 29 0a 09 09 20 20 20 20 20 20 28 66 6f 72 2d 65 )... (for-e
c1e0: 61 63 68 0a 09 09 20 20 20 20 20 20 20 28 6c 61 ach... (la
c1f0: 6d 62 64 61 20 28 66 73 70 65 63 29 0a 09 09 09 mbda (fspec)....
c200: 20 28 70 72 69 6e 74 20 22 66 73 70 65 63 3a 20 (print "fspec:
c210: 22 20 66 73 70 65 63 29 0a 09 09 09 20 28 6c 65 " fspec).... (le
c220: 74 2a 20 28 28 75 72 6c 20 20 20 20 20 20 20 20 t* ((url
c230: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
c240: 20 28 63 61 72 20 66 73 70 65 63 29 29 29 20 3b (car fspec))) ;
c250: 3b 20 54 48 49 53 20 43 4f 55 4c 44 20 42 45 20 ; THIS COULD BE
c260: 54 52 4f 55 42 4c 45 2e 20 41 64 64 20 6f 70 74 TROUBLE. Add opt
c270: 69 6f 6e 20 74 6f 20 72 65 61 64 69 6e 67 20 6c ion to reading l
c280: 69 6e 65 20 74 6f 20 72 65 74 75 72 6e 20 61 73 ine to return as
c290: 20 73 74 72 69 6e 67 2e 0a 09 09 09 09 28 62 72 string......(br
c2a0: 61 6e 63 68 20 20 20 20 20 20 28 63 64 72 20 66 anch (cdr f
c2b0: 73 70 65 63 29 29 0a 09 09 09 09 28 75 72 6c 2d spec)).....(url-
c2c0: 69 73 2d 66 69 6c 65 20 28 73 74 72 69 6e 67 2d is-file (string-
c2d0: 6d 61 74 63 68 20 22 5e 28 2f 7c 66 69 6c 65 3a match "^(/|file:
c2e0: 29 2e 2a 24 22 20 75 72 6c 29 29 0a 09 09 09 09 ).*$" url)).....
c2f0: 28 66 6e 61 6d 65 20 20 20 20 20 20 20 28 63 6f (fname (co
c300: 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 nc (common:get-s
c310: 69 67 6e 61 74 75 72 65 20 75 72 6c 29 20 22 2e ignature url) ".
c320: 66 6f 73 73 69 6c 22 29 29 0a 09 09 09 09 28 66 fossil")).....(f
c330: 64 69 72 20 20 20 20 20 20 20 20 28 63 6f 6e 63 dir (conc
c340: 20 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e "/tmp/" (curren
c350: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2f 6d t-user-name) "/m
c360: 74 75 74 69 6c 5f 63 61 63 68 65 22 29 29 29 0a tutil_cache"))).
c370: 09 09 09 20 20 20 3b 3b 20 28 69 66 20 28 6e 6f ... ;; (if (no
c380: 74 20 75 72 6c 2d 69 73 2d 66 69 6c 65 29 20 3b t url-is-file) ;
c390: 3b 20 6e 65 65 64 20 74 6f 20 73 79 6e 63 20 66 ; need to sync f
c3a0: 69 72 73 74 20 2d 2d 2d 20 66 6f 72 20 6e 6f 77 irst --- for now
c3b0: 2c 20 63 6c 6f 6e 65 20 27 65 6d 20 61 6c 6c 2e , clone 'em all.
c3c0: 0a 09 09 09 20 20 20 28 66 6f 73 73 69 6c 3a 63 .... (fossil:c
c3d0: 6c 6f 6e 65 2d 6f 72 2d 73 79 6e 63 20 75 72 6c lone-or-sync url
c3e0: 20 66 6e 61 6d 65 20 66 64 69 72 29 20 3b 3b 20 fname fdir) ;;
c3f0: 29 0a 09 09 09 20 20 20 28 6c 65 74 2d 76 61 6c ).... (let-val
c400: 75 65 73 20 28 28 28 64 61 74 65 74 69 6d 65 20 ues (((datetime
c410: 6e 6f 64 65 29 0a 09 09 09 09 09 20 28 66 6f 73 node)...... (fos
c420: 73 69 6c 3a 6c 61 73 74 2d 63 68 61 6e 67 65 2d sil:last-change-
c430: 6e 6f 64 65 2d 61 6e 64 2d 74 69 6d 65 20 66 64 node-and-time fd
c440: 69 72 20 66 6e 61 6d 65 20 62 72 61 6e 63 68 29 ir fname branch)
c450: 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 )).... (if (
c460: 6e 75 6c 6c 3f 20 73 74 61 72 74 74 69 6d 65 73 null? starttimes
c470: 29 0a 09 09 09 09 20 28 70 75 73 68 2d 72 75 6e )..... (push-run
c480: 2d 73 70 65 63 20 74 6f 72 75 6e 20 63 6f 6e 74 -spec torun cont
c490: 6f 75 72 20 72 75 6e 6b 65 79 0a 09 09 09 09 09 our runkey......
c4a0: 09 60 28 28 6d 65 73 73 61 67 65 20 20 2e 20 2c .`((message . ,
c4b0: 28 63 6f 6e 63 20 22 66 6f 73 73 69 6c 3a 22 20 (conc "fossil:"
c4c0: 62 72 61 6e 63 68 20 22 2d 6e 65 76 65 72 72 75 branch "-neverru
c4d0: 6e 22 29 29 0a 09 09 09 09 09 09 20 20 28 72 75 n"))....... (ru
c4e0: 6e 6e 61 6d 65 20 20 2e 20 2c 28 63 6f 6e 63 20 nname . ,(conc
c4f0: 72 75 6e 6e 61 6d 65 20 22 2d 22 20 6e 6f 64 65 runname "-" node
c500: 29 29 0a 09 09 09 09 09 09 20 20 28 72 75 6e 74 ))....... (runt
c510: 72 61 6e 73 20 2e 20 2c 72 75 6e 74 72 61 6e 73 rans . ,runtrans
c520: 29 0a 09 09 09 09 09 09 20 20 28 61 72 65 61 73 )....... (areas
c530: 20 20 20 20 2e 20 2c 61 72 65 61 73 29 0a 09 09 . ,areas)...
c540: 09 09 09 09 20 20 3b 3b 20 28 74 61 72 67 65 74 .... ;; (target
c550: 20 20 20 2e 20 2c 72 75 6e 6b 65 79 29 0a 09 09 . ,runkey)...
c560: 09 09 09 09 20 20 28 61 63 74 69 6f 6e 20 20 20 .... (action
c570: 2e 20 2c 61 63 74 69 6f 6e 29 0a 20 20 20 20 20 . ,action).
c580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 0a )).
c5b0: 09 09 09 09 20 28 69 66 20 28 3e 20 64 61 74 65 .... (if (> date
c5c0: 74 69 6d 65 20 6c 61 73 74 2d 72 75 6e 29 20 3b time last-run) ;
c5d0: 3b 20 63 68 61 6e 67 65 20 74 69 6d 65 20 69 73 ; change time is
c5e0: 20 67 72 65 61 74 65 72 20 74 68 61 6e 20 6c 61 greater than la
c5f0: 73 74 2d 72 75 6e 20 74 69 6d 65 0a 09 09 09 09 st-run time.....
c600: 20 20 20 20 20 28 70 75 73 68 2d 72 75 6e 2d 73 (push-run-s
c610: 70 65 63 20 74 6f 72 75 6e 20 63 6f 6e 74 6f 75 pec torun contou
c620: 72 20 72 75 6e 6b 65 79 0a 09 09 09 09 09 09 20 r runkey.......
c630: 20 20 20 60 28 28 6d 65 73 73 61 67 65 20 20 2e `((message .
c640: 20 2c 28 63 6f 6e 63 20 22 66 6f 73 73 69 6c 3a ,(conc "fossil:
c650: 22 20 62 72 61 6e 63 68 20 22 2d 22 20 6e 6f 64 " branch "-" nod
c660: 65 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 e)).......
c670: 28 72 75 6e 6e 61 6d 65 20 20 2e 20 2c 28 63 6f (runname . ,(co
c680: 6e 63 20 72 75 6e 6e 61 6d 65 20 22 2d 22 20 6e nc runname "-" n
c690: 6f 64 65 29 29 0a 09 09 09 09 09 09 20 20 20 20 ode)).......
c6a0: 20 20 28 72 75 6e 74 72 61 6e 73 20 2e 20 2c 72 (runtrans . ,r
c6b0: 75 6e 74 72 61 6e 73 29 0a 09 09 09 09 09 09 20 untrans).......
c6c0: 20 20 20 20 20 28 61 72 65 61 73 20 20 20 20 2e (areas .
c6d0: 20 2c 61 72 65 61 73 29 0a 09 09 09 09 09 09 20 ,areas).......
c6e0: 20 20 20 20 20 3b 3b 20 28 74 61 72 67 65 74 20 ;; (target
c6f0: 20 20 2e 20 2c 72 75 6e 6b 65 79 29 0a 09 09 09 . ,runkey)....
c700: 09 09 09 20 20 20 20 20 20 28 61 63 74 69 6f 6e ... (action
c710: 20 20 20 2e 20 2c 61 63 74 69 6f 6e 29 0a 09 09 . ,action)...
c720: 09 09 09 09 20 20 20 20 20 20 28 62 72 61 6e 63 .... (branc
c730: 68 20 20 20 2e 20 2c 62 72 61 6e 63 68 29 0a 09 h . ,branch)..
c740: 09 09 09 09 09 20 20 20 20 20 20 28 75 72 6c 20 ..... (url
c750: 20 20 20 20 20 2e 20 2c 75 72 6c 29 0a 09 09 09 . ,url)....
c760: 09 09 09 20 20 20 20 20 20 28 63 6c 6f 6e 65 20 ... (clone
c770: 20 20 20 2e 20 2c 28 63 6f 6e 63 20 66 64 69 72 . ,(conc fdir
c780: 20 22 2f 22 20 66 6e 61 6d 65 29 29 0a 20 20 20 "/" fname)).
c790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7c0: 20 20 20 29 29 29 29 0a 09 09 09 20 20 20 20 20 ))))....
c7d0: 28 70 72 69 6e 74 20 22 47 6f 74 20 64 61 74 65 (print "Got date
c7e0: 74 69 6d 65 3d 22 20 64 61 74 65 74 69 6d 65 20 time=" datetime
c7f0: 22 20 6e 6f 64 65 3d 22 20 6e 6f 64 65 29 29 29 " node=" node)))
c800: 29 0a 09 09 20 20 20 20 20 20 20 76 61 6c 2d 61 )... val-a
c810: 6c 69 73 74 29 29 0a 0a 09 09 20 20 20 20 20 3b list)).... ;
c820: 3b 20 73 65 6e 73 6f 72 20 6c 6f 6f 6b 69 6e 67 ; sensor looking
c830: 20 66 6f 72 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 for one or more
c840: 20 66 69 6c 65 73 20 6e 65 77 65 72 20 74 68 61 files newer tha
c850: 6e 20 72 65 66 65 72 65 6e 63 65 0a 09 09 20 20 n reference...
c860: 20 20 20 3b 3b 0a 09 09 20 20 20 20 20 28 28 66 ;;... ((f
c870: 69 6c 65 20 66 69 6c 65 2d 6f 72 29 20 3b 3b 20 ile file-or) ;;
c880: 6f 6e 65 20 6f 72 20 6d 6f 72 65 20 66 69 6c 65 one or more file
c890: 73 20 6d 75 73 74 20 62 65 20 6e 65 77 65 72 20 s must be newer
c8a0: 74 68 61 6e 20 74 68 65 20 72 65 66 65 72 65 6e than the referen
c8b0: 63 65 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a ce... (let*
c8c0: 20 28 28 79 6f 75 6e 67 65 73 74 64 61 74 20 28 ((youngestdat (
c8d0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 79 6f 75 6e 67 common:get-young
c8e0: 65 73 74 20 28 63 6f 6d 6d 6f 6e 3a 62 61 73 68 est (common:bash
c8f0: 2d 67 6c 6f 62 20 66 69 6c 65 2d 67 6c 6f 62 73 -glob file-globs
c900: 29 29 29 0a 09 09 09 20 20 20 20 20 28 79 6f 75 ))).... (you
c910: 6e 67 65 73 74 6d 6f 64 20 28 63 61 72 20 79 6f ngestmod (car yo
c920: 75 6e 67 65 73 74 64 61 74 29 29 29 0a 09 09 09 ungestdat)))....
c930: 3b 3b 20 28 70 72 69 6e 74 20 22 79 6f 75 6e 67 ;; (print "young
c940: 65 73 74 6d 6f 64 3a 20 22 20 79 6f 75 6e 67 65 estmod: " younge
c950: 73 74 6d 6f 64 20 22 20 73 74 61 72 74 74 69 6d stmod " starttim
c960: 65 73 3a 20 22 20 73 74 61 72 74 74 69 6d 65 73 es: " starttimes
c970: 29 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 )....(if (null?
c980: 73 74 61 72 74 74 69 6d 65 73 29 20 3b 3b 20 74 starttimes) ;; t
c990: 68 69 73 20 74 61 72 67 65 74 20 68 61 73 20 6e his target has n
c9a0: 65 76 65 72 20 62 65 65 6e 20 72 75 6e 0a 09 09 ever been run...
c9b0: 09 20 20 20 20 28 70 75 73 68 2d 72 75 6e 2d 73 . (push-run-s
c9c0: 70 65 63 20 74 6f 72 75 6e 20 63 6f 6e 74 6f 75 pec torun contou
c9d0: 72 20 72 75 6e 6b 65 79 0a 09 09 09 09 09 20 20 r runkey......
c9e0: 20 60 28 28 6d 65 73 73 61 67 65 20 20 2e 20 22 `((message . "
c9f0: 66 69 6c 65 3a 6e 65 76 65 72 72 75 6e 22 29 0a file:neverrun").
ca00: 09 09 09 09 09 20 20 20 20 20 28 61 63 74 69 6f ..... (actio
ca10: 6e 20 20 20 2e 20 2c 61 63 74 69 6f 6e 29 0a 09 n . ,action)..
ca20: 09 09 09 09 20 20 20 20 20 28 72 75 6e 74 72 61 .... (runtra
ca30: 6e 73 20 2e 20 2c 72 75 6e 74 72 61 6e 73 29 0a ns . ,runtrans).
ca40: 09 09 09 09 09 20 20 20 20 20 3b 3b 20 28 74 61 ..... ;; (ta
ca50: 72 67 65 74 20 20 20 2e 20 2c 72 75 6e 6b 65 79 rget . ,runkey
ca60: 29 0a 09 09 09 09 09 20 20 20 20 20 28 61 72 65 )...... (are
ca70: 61 73 20 20 20 20 2e 20 2c 61 72 65 61 73 29 0a as . ,areas).
ca80: 09 09 09 09 09 20 20 20 20 20 28 72 75 6e 6e 61 ..... (runna
ca90: 6d 65 20 20 2e 20 2c 72 75 6e 6e 61 6d 65 29 29 me . ,runname))
caa0: 29 0a 09 09 09 3b 3b 20 28 66 6f 72 2d 65 61 63 )....;; (for-eac
cab0: 68 0a 09 09 09 3b 3b 20 20 28 6c 61 6d 62 64 61 h....;; (lambda
cac0: 20 28 73 74 61 72 74 74 69 6d 65 29 20 3b 3b 20 (starttime) ;;
cad0: 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 69 6d 65 look at the time
cae0: 20 74 68 65 20 6c 61 73 74 20 72 75 6e 20 77 61 the last run wa
caf0: 73 20 6b 69 63 6b 65 64 20 6f 66 66 20 66 6f 72 s kicked off for
cb00: 20 74 68 69 73 20 63 6f 6e 74 6f 75 72 0a 09 09 this contour...
cb10: 09 3b 3b 20 20 20 20 28 69 66 20 28 3e 20 79 6f .;; (if (> yo
cb20: 75 6e 67 65 73 74 6d 6f 64 20 28 63 64 72 20 73 ungestmod (cdr s
cb30: 74 61 72 74 74 69 6d 65 29 29 0a 09 09 09 3b 3b tarttime))....;;
cb40: 20 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 3b . (begin....;
cb50: 3b 20 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 ; . (print "
cb60: 73 74 61 72 74 74 69 6d 65 20 79 6f 75 6e 67 65 starttime younge
cb70: 72 20 74 68 61 6e 20 79 6f 75 6e 67 65 73 74 6d r than youngestm
cb80: 6f 64 3a 20 22 20 73 74 61 72 74 74 69 6d 65 20 od: " starttime
cb90: 22 20 59 6f 75 6e 67 65 73 74 6d 6f 64 3a 20 22 " Youngestmod: "
cba0: 20 79 6f 75 6e 67 65 73 74 6d 6f 64 29 0a 09 09 youngestmod)...
cbb0: 09 20 20 20 20 28 69 66 20 28 3e 20 79 6f 75 6e . (if (> youn
cbc0: 67 65 73 74 6d 6f 64 20 6c 61 73 74 2d 72 75 6e gestmod last-run
cbd0: 29 0a 09 09 09 09 28 70 75 73 68 2d 72 75 6e 2d ).....(push-run-
cbe0: 73 70 65 63 20 74 6f 72 75 6e 20 63 6f 6e 74 6f spec torun conto
cbf0: 75 72 20 72 75 6e 6b 65 79 0a 09 09 09 09 09 20 ur runkey......
cc00: 20 20 20 20 20 20 60 28 28 6d 65 73 73 61 67 65 `((message
cc10: 20 20 2e 20 2c 28 63 6f 6e 63 20 72 75 6c 65 74 . ,(conc rulet
cc20: 79 70 65 20 22 3a 22 20 28 63 61 64 72 20 79 6f ype ":" (cadr yo
cc30: 75 6e 67 65 73 74 64 61 74 29 29 29 0a 09 09 09 ungestdat)))....
cc40: 09 09 09 20 28 61 63 74 69 6f 6e 20 20 20 2e 20 ... (action .
cc50: 2c 61 63 74 69 6f 6e 29 0a 09 09 09 09 09 09 20 ,action).......
cc60: 3b 3b 20 28 74 61 72 67 65 74 20 20 20 2e 20 2c ;; (target . ,
cc70: 72 75 6e 6b 65 79 29 0a 09 09 09 09 09 09 20 28 runkey)....... (
cc80: 72 75 6e 74 72 61 6e 73 20 2e 20 2c 72 75 6e 74 runtrans . ,runt
cc90: 72 61 6e 73 29 0a 09 09 09 09 09 09 20 28 61 72 rans)....... (ar
cca0: 65 61 73 20 20 20 20 2e 20 2c 61 72 65 61 73 29 eas . ,areas)
ccb0: 0a 09 09 09 09 09 09 20 28 72 75 6e 6e 61 6d 65 ....... (runname
ccc0: 20 20 2e 20 2c 72 75 6e 6e 61 6d 65 29 0a 09 09 . ,runname)...
ccd0: 09 09 09 09 20 29 29 29 29 29 29 0a 0a 09 09 20 .... ))))))....
cce0: 20 20 20 20 3b 3b 20 61 6c 6c 20 67 6c 6f 62 62 ;; all globb
ccf0: 65 64 20 66 69 6c 65 73 20 6d 75 73 74 20 62 65 ed files must be
cd00: 20 6e 65 77 65 72 20 74 68 61 6e 20 74 68 65 20 newer than the
cd10: 72 65 66 65 72 65 6e 63 65 0a 09 09 20 20 20 20 reference...
cd20: 20 3b 3b 0a 09 09 20 20 20 20 20 28 28 66 69 6c ;;... ((fil
cd30: 65 2d 61 6e 64 29 20 3b 3b 20 61 6c 6c 20 66 69 e-and) ;; all fi
cd40: 6c 65 73 20 6d 75 73 74 20 62 65 20 6e 65 77 65 les must be newe
cd50: 72 20 74 68 61 6e 20 74 68 65 20 72 65 66 65 72 r than the refer
cd60: 65 6e 63 65 0a 09 09 20 20 20 20 20 20 28 6c 65 ence... (le
cd70: 74 2a 20 28 28 79 6f 75 6e 67 65 73 74 64 61 74 t* ((youngestdat
cd80: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 79 6f 75 (common:get-you
cd90: 6e 67 65 73 74 20 66 69 6c 65 2d 67 6c 6f 62 73 ngest file-globs
cda0: 29 29 0a 09 09 09 20 20 20 20 20 28 79 6f 75 6e )).... (youn
cdb0: 67 65 73 74 6d 6f 64 20 28 63 61 72 20 79 6f 75 gestmod (car you
cdc0: 6e 67 65 73 74 64 61 74 29 29 0a 09 09 09 20 20 ngestdat))....
cdd0: 20 20 20 28 73 75 63 63 65 73 73 20 20 20 20 20 (success
cde0: 23 74 29 29 20 3b 3b 20 61 6e 79 20 63 61 73 65 #t)) ;; any case
cdf0: 73 20 6f 66 20 6e 6f 74 20 74 72 75 65 2c 20 73 s of not true, s
ce00: 65 74 20 66 6c 61 67 20 74 6f 20 23 66 20 66 6f et flag to #f fo
ce10: 72 20 41 4e 44 0a 09 09 09 3b 3b 20 28 70 72 69 r AND....;; (pri
ce20: 6e 74 20 22 79 6f 75 6e 67 65 73 74 6d 6f 64 3a nt "youngestmod:
ce30: 20 22 20 79 6f 75 6e 67 65 73 74 6d 6f 64 20 22 " youngestmod "
ce40: 20 73 74 61 72 74 74 69 6d 65 73 3a 20 22 20 73 starttimes: " s
ce50: 74 61 72 74 74 69 6d 65 73 29 0a 09 09 09 28 69 tarttimes)....(i
ce60: 66 20 28 6e 75 6c 6c 3f 20 73 74 61 72 74 74 69 f (null? startti
ce70: 6d 65 73 29 20 3b 3b 20 74 68 69 73 20 74 61 72 mes) ;; this tar
ce80: 67 65 74 20 68 61 73 20 6e 65 76 65 72 20 62 65 get has never be
ce90: 65 6e 20 72 75 6e 0a 09 09 09 20 20 20 20 28 70 en run.... (p
cea0: 75 73 68 2d 72 75 6e 2d 73 70 65 63 20 74 6f 72 ush-run-spec tor
ceb0: 75 6e 20 63 6f 6e 74 6f 75 72 20 72 75 6e 6b 65 un contour runke
cec0: 79 0a 09 09 09 09 09 20 20 20 60 28 28 6d 65 73 y...... `((mes
ced0: 73 61 67 65 20 20 2e 20 22 66 69 6c 65 3a 6e 65 sage . "file:ne
cee0: 76 65 72 72 75 6e 22 29 0a 09 09 09 09 09 20 20 verrun")......
cef0: 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 2e 20 2c (runname . ,
cf00: 72 75 6e 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 runname)......
cf10: 20 20 20 28 72 75 6e 74 72 61 6e 73 20 2e 20 2c (runtrans . ,
cf20: 72 75 6e 74 72 61 6e 73 29 0a 09 09 09 09 09 20 runtrans)......
cf30: 20 20 20 20 28 61 72 65 61 73 20 20 20 20 2e 20 (areas .
cf40: 2c 61 72 65 61 73 29 0a 09 09 09 09 09 20 20 20 ,areas)......
cf50: 20 20 3b 3b 20 28 74 61 72 67 65 74 20 20 20 2e ;; (target .
cf60: 20 2c 72 75 6e 6b 65 79 29 0a 09 09 09 09 09 20 ,runkey)......
cf70: 20 20 20 20 28 61 63 74 69 6f 6e 20 20 20 2e 20 (action .
cf80: 2c 61 63 74 69 6f 6e 29 29 29 0a 09 09 09 20 20 ,action)))....
cf90: 20 20 3b 3b 20 4e 42 2f 2f 20 49 20 74 68 69 6e ;; NB// I thin
cfa0: 6b 20 74 68 69 73 20 69 73 20 77 72 6f 6e 67 2e k this is wrong.
cfb0: 20 49 74 20 73 68 6f 75 6c 64 20 62 65 20 6c 6f It should be lo
cfc0: 6f 6b 69 6e 67 20 61 74 20 6c 61 73 74 2d 72 75 oking at last-ru
cfd0: 6e 20 6f 6e 6c 79 2e 0a 09 09 09 20 20 20 20 28 n only..... (
cfe0: 69 66 20 28 3e 20 79 6f 75 6e 67 65 73 74 6d 6f if (> youngestmo
cff0: 64 20 6c 61 73 74 2d 72 75 6e 29 20 3b 3b 20 57 d last-run) ;; W
d000: 41 49 54 21 21 20 53 68 6f 75 6c 64 6e 27 74 20 AIT!! Shouldn't
d010: 66 69 6c 65 2d 61 6e 64 20 62 65 20 6c 6f 6f 6b file-and be look
d020: 69 6e 67 20 61 74 20 74 68 65 20 2a 6f 6c 64 65 ing at the *olde
d030: 73 74 2a 20 66 69 6c 65 20 28 74 68 75 73 20 61 st* file (thus a
d040: 6c 6c 20 61 72 65 20 79 6f 75 6e 67 65 72 20 74 ll are younger t
d050: 68 61 6e 20 2e 2e 2e 29 0a 09 09 09 09 0a 09 09 han ...)........
d060: 09 09 3b 3b 20 09 09 09 20 20 20 20 28 66 6f 72 ..;; ... (for
d070: 2d 65 61 63 68 0a 09 09 09 09 3b 3b 20 09 09 09 -each.....;; ...
d080: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 (lambda (st
d090: 61 72 74 74 69 6d 65 29 20 3b 3b 20 6c 6f 6f 6b arttime) ;; look
d0a0: 20 61 74 20 74 68 65 20 74 69 6d 65 20 74 68 65 at the time the
d0b0: 20 6c 61 73 74 20 72 75 6e 20 77 61 73 20 6b 69 last run was ki
d0c0: 63 6b 65 64 20 6f 66 66 20 66 6f 72 20 74 68 69 cked off for thi
d0d0: 73 20 63 6f 6e 74 6f 75 72 0a 09 09 09 09 3b 3b s contour.....;;
d0e0: 20 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 ... (if (
d0f0: 3c 20 79 6f 75 6e 67 65 73 74 6d 6f 64 20 28 63 < youngestmod (c
d100: 64 72 20 73 74 61 72 74 74 69 6d 65 29 29 0a 09 dr starttime))..
d110: 09 09 09 3b 3b 20 09 09 09 09 20 20 20 28 73 65 ...;; .... (se
d120: 74 21 20 73 75 63 63 65 73 73 20 23 66 29 29 29 t! success #f)))
d130: 0a 09 09 09 09 3b 3b 20 09 09 09 20 20 20 20 20 .....;; ...
d140: 73 74 61 72 74 74 69 6d 65 73 29 29 0a 09 09 09 starttimes))....
d150: 09 3b 3b 20 09 09 09 28 69 66 20 73 75 63 63 65 .;; ...(if succe
d160: 73 73 0a 09 09 09 09 3b 3b 20 09 09 09 20 20 20 ss.....;; ...
d170: 20 28 62 65 67 69 6e 0a 09 09 09 09 3b 3b 20 09 (begin.....;; .
d180: 09 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 .. (print "
d190: 73 74 61 72 74 74 69 6d 65 20 79 6f 75 6e 67 65 starttime younge
d1a0: 72 20 74 68 61 6e 20 79 6f 75 6e 67 65 73 74 6d r than youngestm
d1b0: 6f 64 3a 20 22 20 73 74 61 72 74 74 69 6d 65 20 od: " starttime
d1c0: 22 20 59 6f 75 6e 67 65 73 74 6d 6f 64 3a 20 22 " Youngestmod: "
d1d0: 20 79 6f 75 6e 67 65 73 74 6d 6f 64 29 0a 09 09 youngestmod)...
d1e0: 09 09 28 70 75 73 68 2d 72 75 6e 2d 73 70 65 63 ..(push-run-spec
d1f0: 20 74 6f 72 75 6e 20 63 6f 6e 74 6f 75 72 20 72 torun contour r
d200: 75 6e 6b 65 79 0a 09 09 09 09 09 20 20 20 20 20 unkey......
d210: 20 20 60 28 28 6d 65 73 73 61 67 65 20 20 2e 20 `((message .
d220: 2c 28 63 6f 6e 63 20 72 75 6c 65 74 79 70 65 20 ,(conc ruletype
d230: 22 3a 22 20 28 63 61 64 72 20 79 6f 75 6e 67 65 ":" (cadr younge
d240: 73 74 64 61 74 29 29 29 0a 09 09 09 09 09 09 20 stdat))).......
d250: 28 72 75 6e 6e 61 6d 65 20 20 2e 20 2c 72 75 6e (runname . ,run
d260: 6e 61 6d 65 29 0a 09 09 09 09 09 09 20 28 72 75 name)....... (ru
d270: 6e 74 72 61 6e 73 20 2e 20 2c 72 75 6e 74 72 61 ntrans . ,runtra
d280: 6e 73 29 0a 09 09 09 09 09 09 20 3b 3b 20 28 74 ns)....... ;; (t
d290: 61 72 67 65 74 20 20 20 2e 20 2c 72 75 6e 6b 65 arget . ,runke
d2a0: 79 29 0a 09 09 09 09 09 09 20 28 61 72 65 61 73 y)....... (areas
d2b0: 20 20 20 20 2e 20 2c 61 72 65 61 73 29 0a 09 09 . ,areas)...
d2c0: 09 09 09 09 20 28 61 63 74 69 6f 6e 20 20 20 2e .... (action .
d2d0: 20 2c 61 63 74 69 6f 6e 29 0a 09 09 09 09 09 09 ,action).......
d2e0: 20 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 28 ))))))... (
d2f0: 65 6c 73 65 20 28 70 72 69 6e 74 20 22 45 52 52 else (print "ERR
d300: 4f 52 3a 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 OR: unrecognised
d310: 20 72 75 6c 65 20 5c 22 22 20 72 75 6c 65 74 79 rule \"" rulety
d320: 70 65 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 pe)))))..
d330: 6b 65 79 64 61 74 73 29 29 29 20 3b 3b 20 73 65 keydats))) ;; se
d340: 6e 73 65 20 72 75 6c 65 73 0a 09 20 20 28 68 61 nse rules.. (ha
d350: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 72 67 sh-table-keys rg
d360: 63 6f 6e 66 29 29 0a 09 20 0a 09 20 3b 3b 20 6e conf)).. .. ;; n
d370: 6f 77 20 68 61 76 65 20 74 6f 20 72 75 6e 20 70 ow have to run p
d380: 6f 70 75 6c 61 74 65 64 0a 09 20 28 66 6f 72 2d opulated.. (for-
d390: 65 61 63 68 0a 09 20 20 28 6c 61 6d 62 64 61 20 each.. (lambda
d3a0: 28 63 6f 6e 74 6f 75 72 29 0a 09 20 20 20 20 28 (contour).. (
d3b0: 6c 65 74 2a 20 28 28 63 76 61 6c 20 20 20 20 20 let* ((cval
d3c0: 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c (or (configf:l
d3d0: 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 63 6f ookup mtconf "co
d3e0: 6e 74 6f 75 72 73 22 20 63 6f 6e 74 6f 75 72 29 ntours" contour)
d3f0: 20 22 22 29 29 0a 09 09 20 20 20 28 63 76 61 6c ""))... (cval
d400: 2d 61 6c 69 73 74 20 28 63 6f 6d 6d 6f 6e 3a 76 -alist (common:v
d410: 61 6c 2d 3e 61 6c 69 73 74 20 63 76 61 6c 29 29 al->alist cval))
d420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d430: 20 20 20 20 20 3b 3b 20 42 45 57 41 52 45 20 2e ;; BEWARE .
d440: 2e 2e 20 4e 4f 54 20 74 68 65 20 73 61 6d 65 20 .. NOT the same
d450: 76 61 6c 2d 61 6c 69 73 74 20 61 73 20 61 62 6f val-alist as abo
d460: 76 65 21 0a 09 09 20 20 20 28 61 72 65 61 73 20 ve!... (areas
d470: 20 20 20 20 20 28 76 61 6c 2d 61 6c 69 73 74 2d (val-alist-
d480: 3e 61 72 65 61 73 20 63 76 61 6c 2d 61 6c 69 73 >areas cval-alis
d490: 74 29 29 0a 09 09 20 20 20 28 73 65 6c 65 63 74 t))... (select
d4a0: 6f 72 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 or (alist-ref
d4b0: 27 73 65 6c 65 63 74 6f 72 20 63 76 61 6c 2d 61 'selector cval-a
d4c0: 6c 69 73 74 29 29 0a 09 09 20 20 20 28 6d 6f 64 list))... (mod
d4d0: 65 2d 74 61 67 20 20 20 28 61 6e 64 20 73 65 6c e-tag (and sel
d4e0: 65 63 74 6f 72 20 28 73 74 72 69 6e 67 2d 73 70 ector (string-sp
d4f0: 6c 69 74 2d 66 69 65 6c 64 73 20 22 2f 22 20 73 lit-fields "/" s
d500: 65 6c 65 63 74 6f 72 20 23 3a 69 6e 66 69 78 29 elector #:infix)
d510: 29 29 0a 09 09 20 20 20 28 6d 6f 64 65 2d 70 61 ))... (mode-pa
d520: 74 74 20 20 28 61 6e 64 20 6d 6f 64 65 2d 74 61 tt (and mode-ta
d530: 67 20 28 69 66 20 28 65 71 3f 20 28 6c 65 6e 67 g (if (eq? (leng
d540: 74 68 20 6d 6f 64 65 2d 74 61 67 29 20 32 29 28 th mode-tag) 2)(
d550: 63 61 64 72 20 6d 6f 64 65 2d 74 61 67 29 20 23 cadr mode-tag) #
d560: 66 29 29 29 0a 09 09 20 20 20 28 74 61 67 2d 65 f)))... (tag-e
d570: 78 70 72 20 20 20 28 61 6e 64 20 6d 6f 64 65 2d xpr (and mode-
d580: 74 61 67 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6d tag (if (null? m
d590: 6f 64 65 2d 74 61 67 29 20 23 66 20 28 63 61 72 ode-tag) #f (car
d5a0: 20 6d 6f 64 65 2d 74 61 67 29 29 29 29 29 0a 09 mode-tag)))))..
d5b0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 63 6f (print "co
d5c0: 6e 74 6f 75 72 3a 20 22 20 63 6f 6e 74 6f 75 72 ntour: " contour
d5d0: 20 22 20 61 72 65 61 73 3d 22 20 61 72 65 61 73 " areas=" areas
d5e0: 20 22 20 63 76 61 6c 3d 22 20 63 76 61 6c 29 0a " cval=" cval).
d5f0: 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
d600: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
d610: 20 28 72 75 6e 6b 65 79 64 61 74 73 65 74 29 20 (runkeydatset)
d620: 0a 09 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 ... ;; (print "r
d630: 75 6e 6b 65 79 64 61 74 73 65 74 3a 20 22 29 28 unkeydatset: ")(
d640: 70 70 20 72 75 6e 6b 65 79 64 61 74 73 65 74 29 pp runkeydatset)
d650: 0a 09 09 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 ... (let ((runke
d660: 79 20 20 20 20 20 28 63 61 72 20 72 75 6e 6b 65 y (car runke
d670: 79 64 61 74 73 65 74 29 29 0a 09 09 20 20 20 20 ydatset))...
d680: 20 20 20 28 72 75 6e 6b 65 79 64 61 74 73 20 28 (runkeydats (
d690: 63 61 64 72 20 72 75 6e 6b 65 79 64 61 74 73 65 cadr runkeydatse
d6a0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
d6b0: 20 20 20 20 20 20 20 20 20 20 20 29 0a 09 09 20 )...
d6c0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 (for-each...
d6d0: 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 6b 65 (lambda (runke
d6e0: 79 64 61 74 29 0a 09 09 20 20 20 20 20 20 28 66 ydat)... (f
d6f0: 6f 72 2d 65 61 63 68 0a 09 09 20 20 20 20 20 20 or-each...
d700: 20 28 6c 61 6d 62 64 61 20 28 61 72 65 61 29 0a (lambda (area).
d710: 09 09 09 20 28 69 66 20 28 61 72 65 61 2d 61 6c ... (if (area-al
d720: 6c 6f 77 65 64 3f 20 61 72 65 61 20 61 72 65 61 lowed? area area
d730: 73 20 72 75 6e 6b 65 79 20 63 6f 6e 74 6f 75 72 s runkey contour
d740: 20 6d 6f 64 65 2d 70 61 74 74 29 20 3b 3b 20 69 mode-patt) ;; i
d750: 73 20 74 68 69 73 20 61 72 65 61 20 74 6f 20 62 s this area to b
d760: 65 20 68 61 6e 64 6c 65 64 20 28 66 72 6f 6d 20 e handled (from
d770: 61 72 65 61 73 3d 61 2c 62 2c 63 20 4f 52 20 75 areas=a,b,c OR u
d780: 73 69 6e 67 20 61 72 65 61 66 6e 3d 61 62 63 66 sing areafn=abcf
d790: 6e 20 61 6e 64 20 2a 61 72 65 61 2d 63 68 65 63 n and *area-chec
d7a0: 6b 73 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 ks* ...).
d7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7c0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 76 (let* ((av
d7d0: 61 6c 20 20 20 20 20 20 20 28 6f 72 20 28 63 6f al (or (co
d7e0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 nfigf:lookup mtc
d7f0: 6f 6e 66 20 22 61 72 65 61 73 22 20 61 72 65 61 onf "areas" area
d800: 29 20 22 22 29 29 0a 20 20 20 20 20 20 20 20 20 ) "")).
d810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d820: 20 20 20 20 20 20 20 20 20 20 20 28 61 76 61 6c (aval
d830: 2d 61 6c 69 73 74 20 28 63 6f 6d 6d 6f 6e 3a 76 -alist (common:v
d840: 61 6c 2d 3e 61 6c 69 73 74 20 61 76 61 6c 29 29 al->alist aval))
d850: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d870: 20 20 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 20 (runname
d880: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 6e (alist-ref 'run
d890: 6e 61 6d 65 20 72 75 6e 6b 65 79 64 61 74 29 29 name runkeydat))
d8a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8c0: 20 20 20 20 20 28 72 75 6e 74 72 61 6e 73 20 20 (runtrans
d8d0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 72 75 6e (alist-ref 'run
d8e0: 74 72 61 6e 73 20 72 75 6e 6b 65 79 64 61 74 29 trans runkeydat)
d8f0: 29 0a 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 20 20 20
d910: 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 .
d920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d930: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 61 73 (reas
d940: 6f 6e 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 on (alist-re
d950: 66 20 27 6d 65 73 73 61 67 65 20 72 75 6e 6b 65 f 'message runke
d960: 79 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 ydat)).
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 28 73 63 68 65 (sche
d990: 64 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 d (alist-re
d9a0: 66 20 27 73 63 68 65 64 20 20 20 72 75 6e 6b 65 f 'sched runke
d9b0: 79 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 ydat)).
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 20 20 20 20 20 20 28 61 63 74 69 (acti
d9e0: 6f 6e 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 on (alist-re
d9f0: 66 20 27 61 63 74 69 6f 6e 20 20 72 75 6e 6b 65 f 'action runke
da00: 79 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 ydat)).
da10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da20: 20 20 20 20 20 20 20 20 20 20 20 28 64 62 64 65 (dbde
da30: 73 74 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 st (alist-re
da40: 66 20 27 64 62 64 65 73 74 20 20 72 75 6e 6b 65 f 'dbdest runke
da50: 79 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 ydat)).
da60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da70: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 65 (appe
da80: 6e 64 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 nd (alist-re
da90: 66 20 27 61 70 70 65 6e 64 20 20 72 75 6e 6b 65 f 'append runke
daa0: 79 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 ydat)).
dab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dac0: 20 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 (targ
dad0: 65 74 73 20 20 20 20 3b 3b 28 6f 72 20 28 61 6c ets ;;(or (al
dae0: 69 73 74 2d 72 65 66 20 27 74 61 72 67 65 74 20 ist-ref 'target
daf0: 20 72 75 6e 6b 65 79 64 61 74 29 0a 20 20 20 20 runkeydat).
db00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db30: 28 6d 61 70 2d 74 61 72 67 65 74 73 20 6d 74 63 (map-targets mtc
db40: 6f 6e 66 20 61 76 61 6c 2d 61 6c 69 73 74 20 72 onf aval-alist r
db50: 75 6e 6b 65 79 20 61 72 65 61 20 63 6f 6e 74 6f unkey area conto
db60: 75 72 29 29 29 20 3b 3b 20 6f 76 65 72 72 69 64 ur))) ;; overrid
db70: 65 20 77 69 74 68 20 74 61 72 67 65 74 20 69 66 e with target if
db80: 20 66 6f 72 63 65 64 0a 20 20 20 20 20 20 20 20 forced.
db90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dba0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 74 ;;(t
dbb0: 61 72 67 65 74 73 20 20 20 20 28 6f 72 20 28 61 argets (or (a
dbc0: 6c 69 73 74 2d 72 65 66 20 27 74 61 72 67 65 74 list-ref 'target
dbd0: 20 20 72 75 6e 6b 65 79 64 61 74 29 0a 20 20 20 runkeydat).
dbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc00: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
dc10: 20 20 20 28 6d 61 70 2d 74 61 72 67 65 74 73 20 (map-targets
dc20: 6d 74 63 6f 6e 66 20 61 76 61 6c 2d 61 6c 69 73 mtconf aval-alis
dc30: 74 20 72 75 6e 6b 65 79 20 61 72 65 61 20 63 6f t runkey area co
dc40: 6e 74 6f 75 72 29 29 29 29 20 3b 3b 20 6f 76 65 ntour)))) ;; ove
dc50: 72 72 69 64 65 20 77 69 74 68 20 74 61 72 67 65 rride with targe
dc60: 74 20 69 66 20 66 6f 72 63 65 64 0a 20 20 20 20 t if forced.
dc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc80: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4e 45 ;; NE
dc90: 45 44 20 54 4f 20 45 58 50 41 4e 44 20 52 55 4e ED TO EXPAND RUN
dca0: 4b 45 59 20 3d 3e 20 41 4c 4c 20 54 41 52 47 45 KEY => ALL TARGE
dcb0: 54 53 20 4d 41 50 50 45 44 20 41 4e 44 20 54 48 TS MAPPED AND TH
dcc0: 45 4e 20 46 4f 52 45 41 43 48 20 2e 2e 2e 2e 20 EN FOREACH ....
dcd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
dce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcf0: 3b 3b 28 70 72 69 6e 74 20 22 54 61 72 67 65 74 ;;(print "Target
dd00: 73 3a 20 22 20 74 61 72 67 65 74 73 29 0a 20 20 s: " targets).
dd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 ;;(
dd30: 70 72 69 6e 74 20 22 61 6c 69 73 74 3a 20 22 20 print "alist: "
dd40: 28 61 6c 69 73 74 2d 72 65 66 20 27 74 61 72 67 (alist-ref 'targ
dd50: 65 74 20 72 75 6e 6b 65 79 64 61 74 29 29 0a 20 et runkeydat)).
dd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
dd80: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 20 or-each.
dd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dda0: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
ddb0: 28 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 20 (target).
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddd0: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
dde0: 74 20 22 43 72 65 61 74 69 6e 67 20 70 6b 74 20 t "Creating pkt
ddf0: 66 6f 72 20 72 75 6e 6b 65 79 3d 22 20 72 75 6e for runkey=" run
de00: 6b 65 79 20 22 20 74 61 72 67 65 74 3d 22 20 74 key " target=" t
de10: 61 72 67 65 74 20 22 20 63 6f 6e 74 6f 75 72 3d arget " contour=
de20: 22 20 63 6f 6e 74 6f 75 72 20 22 20 61 72 65 61 " contour " area
de30: 3d 22 20 61 72 65 61 20 22 20 61 63 74 69 6f 6e =" area " action
de40: 3d 22 20 61 63 74 69 6f 6e 20 22 20 74 61 67 2d =" action " tag-
de50: 65 78 70 72 3d 22 20 74 61 67 2d 65 78 70 72 20 expr=" tag-expr
de60: 22 20 6d 6f 64 65 2d 70 61 74 74 3d 22 20 6d 6f " mode-patt=" mo
de70: 64 65 2d 70 61 74 74 29 0a 20 20 20 20 20 20 20 de-patt).
de80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de90: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
dea0: 63 61 73 65 20 28 6f 72 20 28 61 6e 64 20 61 63 case (or (and ac
deb0: 74 69 6f 6e 20 28 73 74 72 69 6e 67 2d 3e 73 79 tion (string->sy
dec0: 6d 62 6f 6c 20 61 63 74 69 6f 6e 29 29 20 27 6e mbol action)) 'n
ded0: 6f 61 63 74 69 6f 6e 29 20 20 3b 3b 20 65 6e 73 oaction) ;; ens
dee0: 75 72 65 20 77 65 20 68 61 76 65 20 74 68 65 20 ure we have the
def0: 6e 65 65 64 65 64 20 64 61 74 61 20 74 6f 20 72 needed data to r
df00: 75 6e 20 74 68 69 73 20 61 63 74 69 6f 6e 0a 20 un this action.
df10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 20 20 28 28 6e 6f 61 63 74 69 6f ((noactio
df40: 6e 29 20 20 20 20 20 20 20 20 20 20 20 23 66 29 n) #f)
df50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
df60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df70: 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 29 20 ((run)
df80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
df90: 61 6e 64 20 72 75 6e 6e 61 6d 65 20 72 65 61 73 and runname reas
dfa0: 6f 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 on)).
dfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
dfd0: 79 6e 63 20 73 79 6e 63 2d 70 72 65 70 65 6e 64 ync sync-prepend
dfe0: 29 20 20 28 61 6e 64 20 72 65 61 73 6f 6e 20 64 ) (and reason d
dff0: 62 64 65 73 74 29 29 0a 20 20 20 20 20 20 20 20 bdest)).
e000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e020: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 (else
e030: 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 #f)).
e040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e060: 20 3b 3b 20 69 6e 73 74 65 61 64 20 6f 66 20 75 ;; instead of u
e070: 6e 77 72 61 70 70 69 6e 67 20 74 68 65 20 72 75 nwrapping the ru
e080: 6e 6b 65 79 64 61 74 20 61 6c 69 73 74 2c 20 70 nkeydat alist, p
e090: 61 73 73 20 69 74 20 64 69 72 65 63 74 6c 79 20 ass it directly
e0a0: 74 6f 20 63 72 65 61 74 65 2d 72 75 6e 2d 70 6b to create-run-pk
e0b0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
e0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0d0: 20 20 20 20 20 20 20 20 28 63 72 65 61 74 65 2d (create-
e0e0: 72 75 6e 2d 70 6b 74 20 6d 74 63 6f 6e 66 20 61 run-pkt mtconf a
e0f0: 63 74 69 6f 6e 20 61 72 65 61 20 72 75 6e 6b 65 ction area runke
e100: 79 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 y target runname
e110: 20 6d 6f 64 65 2d 70 61 74 74 0a 20 20 20 20 20 mode-patt.
e120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e150: 20 74 61 67 2d 65 78 70 72 20 70 6b 74 73 64 69 tag-expr pktsdi
e160: 72 20 72 65 61 73 6f 6e 20 63 6f 6e 74 6f 75 72 r reason contour
e170: 20 73 63 68 65 64 20 64 62 64 65 73 74 20 61 70 sched dbdest ap
e180: 70 65 6e 64 20 0a 20 20 20 20 20 20 20 20 20 20 pend .
e190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1b0: 20 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 74 runt
e1c0: 72 61 6e 73 29 20 0a 20 20 20 20 20 20 20 20 20 rans) .
e1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
e1f0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 int "ERROR: Miss
e200: 69 6e 67 20 69 6e 66 6f 20 74 6f 20 6d 61 6b 65 ing info to make
e210: 20 61 20 22 20 61 63 74 69 6f 6e 20 22 20 63 61 a " action " ca
e220: 6c 6c 3a 20 72 75 6e 6b 65 79 3d 22 20 72 75 6e ll: runkey=" run
e230: 6b 65 79 20 22 20 63 6f 6e 74 6f 75 72 3d 22 20 key " contour="
e240: 63 6f 6e 74 6f 75 72 20 22 20 61 72 65 61 3d 22 contour " area="
e250: 20 61 72 65 61 20 20 22 20 74 61 67 2d 65 78 70 area " tag-exp
e260: 72 3d 22 20 74 61 67 2d 65 78 70 72 20 22 20 6d r=" tag-expr " m
e270: 6f 64 65 2d 70 61 74 74 3d 22 20 6d 6f 64 65 2d ode-patt=" mode-
e280: 70 61 74 74 20 22 20 64 62 64 65 73 74 3d 22 20 patt " dbdest="
e290: 64 62 64 65 73 74 29 0a 20 20 20 20 20 20 20 20 dbdest).
e2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
e2c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e2e0: 20 74 61 72 67 65 74 73 29 29 0a 20 20 20 20 20 targets)).
e2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e300: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 (print "
e310: 4e 4f 54 45 3a 20 73 6b 69 70 70 69 6e 67 20 22 NOTE: skipping "
e320: 20 72 75 6e 6b 65 79 64 61 74 20 22 20 66 6f 72 runkeydat " for
e330: 20 61 72 65 61 20 5c 22 22 20 61 72 65 61 20 22 area \"" area "
e340: 5c 22 2c 20 6e 6f 74 20 69 6e 20 22 20 61 72 65 \", not in " are
e350: 61 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 as))).
e360: 20 20 20 20 20 20 20 20 20 20 20 20 20 61 6c 6c all
e370: 2d 61 72 65 61 73 29 29 0a 09 09 20 20 20 20 72 -areas))... r
e380: 75 6e 6b 65 79 64 61 74 73 29 29 29 0a 09 20 20 unkeydats)))..
e390: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
e3a0: 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 (configf:get-sec
e3b0: 74 69 6f 6e 20 74 6f 72 75 6e 20 63 6f 6e 74 6f tion torun conto
e3c0: 75 72 29 29 29 20 3b 3b 20 65 61 63 68 20 63 6f ur))) ;; each co
e3d0: 6e 74 6f 75 72 20 2f 20 74 61 72 67 65 74 0a 09 ntour / target..
e3e0: 09 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 65 73 . ;; (print "res
e3f0: 3d 22 20 72 65 73 29 0a 09 09 20 72 65 73 29 29 =" res)... res))
e400: 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c )).. (hash-tabl
e410: 65 2d 6b 65 79 73 20 74 6f 72 75 6e 29 29 29 29 e-keys torun))))
e420: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 6b )))..(define (pk
e430: 74 2d 3e 63 6d 64 6c 69 6e 65 20 70 6b 74 61 29 t->cmdline pkta)
e440: 0a 20 20 28 6c 65 74 2a 20 28 28 70 61 72 61 6d . (let* ((param
e450: 2d 6d 61 70 70 69 6e 67 2d 61 6c 69 73 74 20 28 -mapping-alist (
e460: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 61 72 61 6d common:get-param
e470: 2d 6d 61 70 70 69 6e 67 20 66 6c 61 76 6f 72 3a -mapping flavor:
e480: 20 27 73 77 69 74 63 68 2d 73 79 6d 62 6f 6c 29 'switch-symbol)
e490: 29 0a 20 20 20 20 20 20 20 20 20 28 61 63 74 69 ). (acti
e4a0: 6f 6e 20 20 20 20 20 20 20 20 28 6f 72 20 28 6c on (or (l
e4b0: 6f 6f 6b 75 70 2d 61 63 74 69 6f 6e 2d 62 79 2d ookup-action-by-
e4c0: 6b 65 79 20 28 61 6c 69 73 74 2d 72 65 66 20 27 key (alist-ref '
e4d0: 41 20 70 6b 74 61 29 29 20 22 6e 6f 61 63 74 69 A pkta)) "noacti
e4e0: 6f 6e 22 29 29 0a 09 20 28 61 63 74 69 6f 6e 2d on")).. (action-
e4f0: 70 61 72 61 6d 20 20 28 63 61 73 65 20 28 73 74 param (case (st
e500: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 ring->symbol act
e510: 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 ion).
e520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
e530: 28 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 (-set-state-stat
e540: 75 73 29 20 28 63 6f 6e 63 20 28 61 6c 69 73 74 us) (conc (alist
e550: 2d 72 65 66 20 27 6c 20 70 6b 74 61 29 20 22 20 -ref 'l pkta) "
e560: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
e570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
e580: 6c 73 65 20 22 22 29 29 29 29 0a 20 20 20 20 28 lse "")))). (
e590: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 fold (lambda (a
e5a0: 72 65 73 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 res).. (let*
e5b0: 28 28 6b 65 79 20 28 63 61 72 20 61 29 29 20 3b ((key (car a)) ;
e5c0: 3b 20 67 65 74 20 74 68 65 20 6b 65 79 20 6e 61 ; get the key na
e5d0: 6d 65 0a 09 09 20 20 20 28 76 61 6c 20 28 63 64 me... (val (cd
e5e0: 72 20 61 29 29 0a 09 09 20 20 20 28 70 61 72 20 r a))... (par
e5f0: 28 6f 72 20 28 6c 6f 6f 6b 75 70 2d 70 61 72 61 (or (lookup-para
e600: 6d 2d 62 79 2d 6b 65 79 20 6b 65 79 29 20 20 3b m-by-key key) ;
e610: 3b 20 6e 65 65 64 20 74 6f 20 63 68 65 63 6b 20 ; need to check
e620: 61 6c 73 6f 20 69 66 20 69 74 20 69 73 20 61 20 also if it is a
e630: 73 77 69 74 63 68 0a 09 09 09 20 20 20 20 28 6c switch.... (l
e640: 6f 6f 6b 75 70 2d 70 61 72 61 6d 2d 62 79 2d 6b ookup-param-by-k
e650: 65 79 20 6b 65 79 20 69 6e 6c 73 74 3a 20 2a 73 ey key inlst: *s
e660: 77 69 74 63 68 2d 6b 65 79 73 2a 29 29 29 29 0a witch-keys*)))).
e670: 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 6b . (print "k
e680: 65 79 3a 20 22 20 6b 65 79 20 22 20 76 61 6c 3a ey: " key " val:
e690: 20 22 20 76 61 6c 20 22 20 70 61 72 3a 20 22 20 " val " par: "
e6a0: 70 61 72 29 0a 09 20 20 20 20 20 20 3b 3b 28 69 par).. ;;(i
e6b0: 66 20 28 61 6e 64 20 70 61 72 20 20 28 6e 6f 74 f (and par (not
e6c0: 20 28 73 74 72 69 6e 67 3d 20 28 73 79 6d 62 6f (string= (symbo
e6d0: 6c 2d 3e 73 74 72 69 6e 67 20 6b 65 79 29 20 22 l->string key) "
e6e0: 47 22 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 G"))).. (if
e6f0: 20 28 61 6e 64 20 70 61 72 29 0a 09 09 20 20 28 (and par)... (
e700: 63 6f 6e 63 20 72 65 73 20 22 20 22 20 28 61 6c conc res " " (al
e710: 69 73 74 2d 72 65 66 20 28 73 74 72 69 6e 67 2d ist-ref (string-
e720: 3e 73 79 6d 62 6f 6c 20 70 61 72 29 20 70 61 72 >symbol par) par
e730: 61 6d 2d 6d 61 70 70 69 6e 67 2d 61 6c 69 73 74 am-mapping-alist
e740: 20 65 71 3f 20 70 61 72 29 20 22 20 22 20 76 61 eq? par) " " va
e750: 6c 29 0a 09 09 20 20 28 69 66 20 28 61 6c 69 73 l)... (if (alis
e760: 74 2d 72 65 66 20 6b 65 79 20 2a 61 64 64 69 74 t-ref key *addit
e770: 69 6f 6e 61 6c 2d 63 61 72 64 73 2a 29 20 3b 3b ional-cards*) ;;
e780: 20 74 68 65 73 65 20 63 61 72 64 73 20 64 6f 20 these cards do
e790: 6e 6f 74 20 74 72 61 6e 73 6c 61 74 65 20 74 6f not translate to
e7a0: 20 70 61 72 61 6d 65 74 65 72 73 20 6f 72 20 73 parameters or s
e7b0: 77 69 74 63 68 65 73 0a 09 09 20 20 20 20 20 20 witches...
e7c0: 72 65 73 0a 09 09 20 20 20 20 20 20 28 62 65 67 res... (beg
e7d0: 69 6e 0a 09 09 09 28 70 72 69 6e 74 20 22 45 52 in....(print "ER
e7e0: 52 4f 52 3a 20 55 6e 6b 6e 6f 77 6e 20 6b 65 79 ROR: Unknown key
e7f0: 20 69 6e 20 70 61 63 6b 65 74 20 5c 22 22 20 6b in packet \"" k
e800: 65 79 20 22 5c 22 20 77 69 74 68 20 76 61 6c 75 ey "\" with valu
e810: 65 20 5c 22 22 20 76 61 6c 20 22 5c 22 22 29 0a e \"" val "\"").
e820: 09 09 09 72 65 73 29 29 29 29 29 0a 09 20 20 28 ...res))))).. (
e830: 63 6f 6e 63 20 22 6d 65 67 61 74 65 73 74 20 22 conc "megatest "
e840: 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 65 (if (not (membe
e850: 72 20 61 63 74 69 6f 6e 20 27 28 22 73 79 6e 63 r action '("sync
e860: 22 29 29 29 0a 09 09 09 09 28 63 6f 6e 63 20 61 "))).....(conc a
e870: 63 74 69 6f 6e 20 22 20 22 20 61 63 74 69 6f 6e ction " " action
e880: 2d 70 61 72 61 6d 29 0a 09 09 09 09 22 22 29 20 -param)....."")
e890: 28 69 66 20 28 6d 65 6d 62 65 72 20 61 63 74 69 (if (member acti
e8a0: 6f 6e 20 27 28 22 2d 72 75 6e 22 20 22 2d 72 65 on '("-run" "-re
e8b0: 72 75 6e 2d 63 6c 65 61 6e 22 20 22 2d 72 65 72 run-clean" "-rer
e8c0: 75 6e 2d 61 6c 6c 22 20 22 2d 6b 69 6c 6c 2d 72 un-all" "-kill-r
e8d0: 65 72 75 6e 22 29 29 0a 20 20 20 20 20 20 20 20 erun")).
e8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e910: 22 2d 72 65 72 75 6e 20 44 45 41 44 2c 41 42 4f "-rerun DEAD,ABO
e920: 52 54 2c 4b 49 4c 4c 45 44 22 0a 20 20 20 20 20 RT,KILLED".
e930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e960: 20 20 20 22 22 29 29 0a 09 20 20 70 6b 74 61 29 "")).. pkta)
e970: 29 29 0a 0a 3b 3b 20 28 75 73 65 20 74 72 61 63 ))..;; (use trac
e980: 65 29 28 74 72 61 63 65 20 70 6b 74 2d 3e 63 6d e)(trace pkt->cm
e990: 64 6c 69 6e 65 29 0a 0a 28 64 65 66 69 6e 65 20 dline)..(define
e9a0: 28 77 72 69 74 65 2d 70 6b 74 20 70 6b 74 73 64 (write-pkt pktsd
e9b0: 69 72 20 75 75 69 64 20 70 6b 74 29 0a 20 20 28 ir uuid pkt). (
e9c0: 69 66 20 70 6b 74 73 64 69 72 0a 20 20 20 20 20 if pktsdir.
e9d0: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
e9e0: 2d 66 69 6c 65 0a 09 20 20 28 63 6f 6e 63 20 70 -file.. (conc p
e9f0: 6b 74 73 64 69 72 20 22 2f 22 20 75 75 69 64 20 ktsdir "/" uuid
ea00: 22 2e 70 6b 74 22 29 0a 09 28 6c 61 6d 62 64 61 ".pkt")..(lambda
ea10: 20 28 29 0a 09 20 20 28 70 72 69 6e 74 20 70 6b ().. (print pk
ea20: 74 29 29 29 0a 20 20 20 20 20 20 28 70 72 69 6e t))). (prin
ea30: 74 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 t "ERROR: cannot
ea40: 20 70 72 6f 63 65 73 73 20 63 6f 6d 6d 61 6e 64 process command
ea50: 73 20 77 69 74 68 6f 75 74 20 61 20 70 6b 74 73 s without a pkts
ea60: 20 64 69 72 65 63 74 6f 72 79 22 29 29 29 0a 0a directory")))..
ea70: 28 64 65 66 69 6e 65 20 28 63 68 65 63 6b 2d 69 (define (check-i
ea80: 66 2d 6d 6f 64 65 70 61 74 74 2d 64 65 66 69 6e f-modepatt-defin
ea90: 65 64 20 20 70 6b 74 61 20 6e 6f 74 69 66 69 63 ed pkta notific
eaa0: 61 74 69 6f 6e 2d 68 6f 6f 6b 20 70 6b 74 66 69 ation-hook pktfi
eab0: 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 le). (let* ((st
eac0: 61 72 74 2d 64 69 72 20 28 61 6c 69 73 74 2d 72 art-dir (alist-r
ead0: 65 66 20 27 53 20 70 6b 74 61 29 29 0a 09 20 28 ef 'S pkta)).. (
eae0: 74 61 72 67 65 74 20 28 6f 72 20 28 61 6c 69 73 target (or (alis
eaf0: 74 2d 72 65 66 20 27 52 20 70 6b 74 61 29 20 28 t-ref 'R pkta) (
eb00: 61 6c 69 73 74 2d 72 65 66 20 27 74 20 70 6b 74 alist-ref 't pkt
eb10: 61 29 29 29 0a 09 20 28 70 61 74 74 20 28 61 6c a))).. (patt (al
eb20: 69 73 74 2d 72 65 66 20 27 6f 20 70 6b 74 61 29 ist-ref 'o pkta)
eb30: 29 0a 09 20 28 75 75 69 64 20 20 20 20 28 61 6c ).. (uuid (al
eb40: 69 73 74 2d 72 65 66 20 27 5a 20 70 6b 74 61 29 ist-ref 'Z pkta)
eb50: 29 0a 09 20 28 63 6d 64 20 28 63 6f 6e 63 20 22 ).. (cmd (conc "
eb60: 6d 65 67 61 74 65 73 74 20 2d 73 68 6f 77 2d 72 megatest -show-r
eb70: 75 6e 63 6f 6e 66 69 67 20 2d 74 61 72 67 65 74 unconfig -target
eb80: 20 22 20 74 61 72 67 65 74 20 22 20 2d 73 74 61 " target " -sta
eb90: 72 74 2d 64 69 72 20 22 20 73 74 61 72 74 2d 64 rt-dir " start-d
eba0: 69 72 29 29 0a 09 20 28 72 65 73 20 20 20 20 28 ir)).. (res (
ebb0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
ebc0: 73 0a 09 09 20 20 65 78 6e 0a 09 09 20 20 23 66 s... exn... #f
ebd0: 0a 09 09 20 20 28 70 72 69 6e 74 20 22 52 75 6e ... (print "Run
ebe0: 6e 69 6e 67 20 22 20 63 6d 64 29 0a 09 09 20 20 ning " cmd)...
ebf0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
ec00: 2d 70 69 70 65 20 63 6d 64 20 72 65 61 64 2d 6c -pipe cmd read-l
ec10: 69 6e 65 73 29 29 29 29 20 0a 20 20 20 20 28 6c ines)))) . (l
ec20: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
ec30: 61 72 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 ar res))..
ec40: 20 28 74 61 69 6c 20 28 63 64 72 20 72 65 73 29 (tail (cdr res)
ec50: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 74 )). (if (st
ec60: 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 20 68 65 ring-contains he
ec70: 64 20 70 61 74 74 29 0a 09 20 20 23 74 0a 09 20 d patt).. #t..
ec80: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c (if (null? tail
ec90: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
eca0: 09 09 28 69 66 20 6e 6f 74 69 66 69 63 61 74 69 ..(if notificati
ecb0: 6f 6e 2d 68 6f 6f 6b 0a 09 09 20 20 20 20 28 6c on-hook... (l
ecc0: 65 74 2a 20 28 28 6e 6f 74 69 66 69 63 61 74 69 et* ((notificati
ecd0: 6f 6e 2d 63 6d 64 20 28 63 6f 6e 63 20 6e 6f 74 on-cmd (conc not
ece0: 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f 6b 20 22 ification-hook "
ecf0: 20 2d 2d 70 6b 74 20 22 20 70 6b 74 66 69 6c 65 --pkt " pktfile
ed00: 20 22 20 2d 2d 6d 73 67 20 49 4e 56 41 4c 49 44 " --msg INVALID
ed10: 5f 4d 4f 44 45 50 41 54 54 22 29 29 29 0a 09 09 _MODEPATT")))...
ed20: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 52 75 (print "Ru
ed30: 6e 6e 69 6e 67 20 22 20 6e 6f 74 69 66 69 63 61 nning " notifica
ed40: 74 69 6f 6e 2d 63 6d 64 29 0a 09 09 20 20 20 20 tion-cmd)...
ed50: 20 20 28 73 79 73 74 65 6d 20 6e 6f 74 69 66 69 (system notifi
ed60: 63 61 74 69 6f 6e 2d 63 6d 64 29 29 29 20 0a 09 cation-cmd))) ..
ed70: 09 23 66 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f .#f).. (loo
ed80: 70 20 28 63 61 72 20 74 61 69 6c 29 20 28 63 64 p (car tail) (cd
ed90: 72 20 74 61 69 6c 29 29 29 29 29 29 29 0a 0a 28 r tail)))))))..(
eda0: 64 65 66 69 6e 65 20 28 63 68 65 63 6b 2d 69 66 define (check-if
edb0: 2d 74 61 72 67 65 74 2d 64 65 66 69 6e 65 64 20 -target-defined
edc0: 70 6b 74 61 20 6e 6f 74 69 66 69 63 61 74 69 6f pkta notificatio
edd0: 6e 2d 68 6f 6f 6b 20 70 6b 74 66 69 6c 65 29 0a n-hook pktfile).
ede0: 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 2d (let* ((start-
edf0: 64 69 72 20 28 61 6c 69 73 74 2d 72 65 66 20 27 dir (alist-ref '
ee00: 53 20 70 6b 74 61 29 29 0a 09 20 28 74 61 72 67 S pkta)).. (targ
ee10: 65 74 20 28 61 6c 69 73 74 2d 72 65 66 20 27 52 et (alist-ref 'R
ee20: 20 70 6b 74 61 29 29 0a 09 20 28 75 75 69 64 20 pkta)).. (uuid
ee30: 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 5a (alist-ref 'Z
ee40: 20 70 6b 74 61 29 29 0a 09 20 28 63 6d 64 20 28 pkta)).. (cmd (
ee50: 63 6f 6e 63 20 22 6d 65 67 61 74 65 73 74 20 2d conc "megatest -
ee60: 6c 69 73 74 2d 74 61 72 67 65 74 73 20 2d 73 74 list-targets -st
ee70: 61 72 74 2d 64 69 72 20 22 20 73 74 61 72 74 2d art-dir " start-
ee80: 64 69 72 29 29 0a 09 20 28 72 65 73 20 20 20 20 dir)).. (res
ee90: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
eea0: 6e 73 0a 09 09 20 20 65 78 6e 0a 09 09 20 20 23 ns... exn... #
eeb0: 66 0a 09 09 20 20 28 70 72 69 6e 74 20 22 52 75 f... (print "Ru
eec0: 6e 6e 69 6e 67 20 22 20 63 6d 64 29 0a 09 09 20 nning " cmd)...
eed0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
eee0: 6d 2d 70 69 70 65 20 63 6d 64 20 72 65 61 64 2d m-pipe cmd read-
eef0: 6c 69 6e 65 73 29 29 29 29 20 0a 20 20 20 20 28 lines)))) . (
ef00: 69 66 20 28 6d 65 6d 62 65 72 20 74 61 72 67 65 if (member targe
ef10: 74 20 72 65 73 29 20 20 0a 09 23 74 20 0a 09 28 t res) ..#t ..(
ef20: 62 65 67 69 6e 20 0a 09 20 20 28 69 66 20 6e 6f begin .. (if no
ef30: 74 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f 6b 0a tification-hook.
ef40: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e . (let* ((n
ef50: 6f 74 69 66 69 63 61 74 69 6f 6e 2d 63 6d 64 20 otification-cmd
ef60: 28 63 6f 6e 63 20 6e 6f 74 69 66 69 63 61 74 69 (conc notificati
ef70: 6f 6e 2d 68 6f 6f 6b 20 22 20 2d 2d 70 6b 74 20 on-hook " --pkt
ef80: 22 20 20 70 6b 74 66 69 6c 65 20 22 20 2d 2d 6d " pktfile " --m
ef90: 73 67 20 49 4e 56 41 4c 49 44 5f 54 41 52 47 45 sg INVALID_TARGE
efa0: 54 22 29 29 29 0a 09 09 28 70 72 69 6e 74 20 22 T")))...(print "
efb0: 52 75 6e 6e 69 6e 67 20 22 20 6e 6f 74 69 66 69 Running " notifi
efc0: 63 61 74 69 6f 6e 2d 63 6d 64 29 0a 09 09 28 73 cation-cmd)...(s
efd0: 79 73 74 65 6d 20 6e 6f 74 69 66 69 63 61 74 69 ystem notificati
efe0: 6f 6e 2d 63 6d 64 29 29 29 0a 09 20 20 23 66 29 on-cmd))).. #f)
eff0: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 76 )))...(define (v
f000: 61 6c 69 64 61 74 65 2d 63 6d 64 20 63 6d 64 20 alidate-cmd cmd
f010: 70 6b 74 61 20 6e 6f 74 69 66 69 63 61 74 69 6f pkta notificatio
f020: 6e 2d 68 6f 6f 6b 20 70 6b 74 66 69 6c 65 29 0a n-hook pktfile).
f030: 20 20 28 6c 65 74 20 28 28 72 65 74 20 23 74 29 (let ((ret #t)
f040: 29 20 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 ) . (if (stri
f050: 6e 67 2d 63 6f 6e 74 61 69 6e 73 20 63 6d 64 20 ng-contains cmd
f060: 22 2d 72 65 71 74 61 72 67 22 29 20 0a 09 28 69 "-reqtarg") ..(i
f070: 66 20 28 63 68 65 63 6b 2d 69 66 2d 74 61 72 67 f (check-if-targ
f080: 65 74 2d 64 65 66 69 6e 65 64 20 70 6b 74 61 20 et-defined pkta
f090: 6e 6f 74 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f notification-hoo
f0a0: 6b 20 70 6b 74 66 69 6c 65 29 0a 09 20 20 20 20 k pktfile)..
f0b0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 70 (begin.. (p
f0c0: 72 69 6e 74 20 22 54 61 72 67 65 74 20 69 73 20 rint "Target is
f0d0: 76 61 6c 69 64 22 29 0a 09 20 20 20 20 20 20 28 valid").. (
f0e0: 69 66 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 if (string-conta
f0f0: 69 6e 73 20 63 6d 64 20 22 2d 6d 6f 64 65 70 61 ins cmd "-modepa
f100: 74 74 22 29 0a 09 09 20 20 28 69 66 20 28 63 68 tt")... (if (ch
f110: 65 63 6b 2d 69 66 2d 6d 6f 64 65 70 61 74 74 2d eck-if-modepatt-
f120: 64 65 66 69 6e 65 64 20 70 6b 74 61 20 6e 6f 74 defined pkta not
f130: 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f 6b 20 70 ification-hook p
f140: 6b 74 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 ktfile)...
f150: 28 70 72 69 6e 74 20 22 4d 6f 64 65 70 61 74 74 (print "Modepatt
f160: 20 69 73 20 76 61 6c 69 64 22 29 0a 09 09 20 20 is valid")...
f170: 20 20 20 20 28 73 65 74 21 20 72 65 74 20 23 66 (set! ret #f
f180: 29 29 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 )))).. (set!
f190: 72 65 74 20 23 66 29 29 0a 09 28 69 66 20 28 73 ret #f))..(if (s
f1a0: 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 20 63 tring-contains c
f1b0: 6d 64 20 22 2d 6d 6f 64 65 70 61 74 74 22 29 0a md "-modepatt").
f1c0: 09 20 20 20 20 28 69 66 20 28 63 68 65 63 6b 2d . (if (check-
f1d0: 69 66 2d 6d 6f 64 65 70 61 74 74 2d 64 65 66 69 if-modepatt-defi
f1e0: 6e 65 64 20 70 6b 74 61 20 6e 6f 74 69 66 69 63 ned pkta notific
f1f0: 61 74 69 6f 6e 2d 68 6f 6f 6b 20 70 6b 74 66 69 ation-hook pktfi
f200: 6c 65 29 0a 09 09 28 70 72 69 6e 74 20 22 4d 6f le)...(print "Mo
f210: 64 65 70 61 74 74 20 69 73 20 76 61 6c 69 64 22 depatt is valid"
f220: 29 0a 09 09 28 73 65 74 21 20 72 65 74 20 23 66 )...(set! ret #f
f230: 29 29 29 29 20 0a 20 20 20 20 72 65 74 29 29 0a )))) . ret)).
f240: 0a 20 20 20 0a 3b 3b 20 63 6f 6c 6c 65 63 74 20 . .;; collect
f250: 61 6c 6c 20 6e 65 65 64 65 64 20 64 61 74 61 20 all needed data
f260: 61 6e 64 20 63 72 65 61 74 65 20 72 75 6e 20 70 and create run p
f270: 6b 74 73 20 66 6f 72 20 63 6f 6e 74 6f 75 72 73 kts for contours
f280: 20 77 69 74 68 20 63 68 61 6e 67 65 64 20 69 6e with changed in
f290: 70 75 74 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 puts.;;.(define
f2a0: 28 64 69 73 70 61 74 63 68 2d 63 6f 6d 6d 61 6e (dispatch-comman
f2b0: 64 73 20 6d 74 63 6f 6e 66 20 74 6f 70 70 61 74 ds mtconf toppat
f2c0: 68 29 0a 20 20 3b 3b 20 77 65 20 61 72 65 20 65 h). ;; we are e
f2d0: 78 70 65 63 74 69 6e 67 20 61 20 64 69 72 65 63 xpecting a direc
f2e0: 74 6f 72 79 20 22 6c 6f 67 73 22 2c 20 63 68 65 tory "logs", che
f2f0: 63 6b 20 61 6e 64 20 63 72 65 61 74 65 20 69 74 ck and create it
f300: 2c 20 63 72 65 61 74 65 20 74 68 65 20 6c 6f 67 , create the log
f310: 20 69 6e 20 2f 74 6d 70 20 69 66 20 6e 6f 74 20 in /tmp if not
f320: 61 62 6c 65 20 74 6f 20 63 72 65 61 74 65 20 6c able to create l
f330: 6f 67 73 20 64 69 72 0a 20 20 28 6c 65 74 20 28 ogs dir. (let (
f340: 28 6c 6f 67 64 69 72 0a 09 20 28 69 66 20 28 69 (logdir.. (if (i
f350: 66 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 f (not (director
f360: 79 3f 20 22 6c 6f 67 73 22 29 29 0a 09 09 20 28 y? "logs"))... (
f370: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
f380: 73 0a 09 09 20 20 65 78 6e 0a 09 09 20 20 23 66 s... exn... #f
f390: 0a 09 09 20 20 28 63 72 65 61 74 65 2d 64 69 72 ... (create-dir
f3a0: 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 0a 09 ectory "logs")..
f3b0: 09 20 20 23 74 29 0a 09 09 20 23 74 29 0a 09 20 . #t)... #t)..
f3c0: 20 20 20 20 22 6c 6f 67 73 22 0a 09 20 20 20 20 "logs"..
f3d0: 20 22 2f 74 6d 70 22 29 29 0a 09 28 63 70 75 6c "/tmp"))..(cpul
f3e0: 6f 61 64 20 28 61 6c 69 73 74 2d 72 65 66 20 27 oad (alist-ref '
f3f0: 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 28 63 adj-proc-load (c
f400: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c ommon:get-normal
f410: 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 23 66 ized-cpu-load #f
f420: 29 29 29 0a 09 28 6d 61 78 6c 6f 61 64 20 28 73 )))..(maxload (s
f430: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f tring->number (o
f440: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
f450: 70 20 6d 74 63 6f 6e 66 20 22 73 65 74 75 70 22 p mtconf "setup"
f460: 20 22 6d 61 78 6c 6f 61 64 22 29 0a 09 09 09 09 "maxload").....
f470: 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (configf:lo
f480: 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 6a 6f 62 okup mtconf "job
f490: 74 6f 6f 6c 73 22 20 22 6d 61 78 6c 6f 61 64 22 tools" "maxload"
f4a0: 29 20 3b 3b 20 72 65 73 70 65 63 74 20 76 61 6c ) ;; respect val
f4b0: 75 65 20 75 73 65 64 20 62 79 20 4d 65 67 61 74 ue used by Megat
f4c0: 65 73 74 20 63 61 6c 6c 73 0a 09 09 09 09 20 20 est calls.....
f4d0: 20 20 20 22 31 2e 31 22 29 29 29 0a 09 28 6e 6f "1.1")))..(no
f4e0: 74 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f 6b 20 tification-hook
f4f0: 28 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (if (configf:loo
f500: 6b 75 70 20 6d 74 63 6f 6e 66 20 22 73 65 74 75 kup mtconf "setu
f510: 70 22 20 22 6e 6f 74 69 66 69 63 61 74 69 6f 6e p" "notification
f520: 2d 68 6f 6f 6b 22 29 0a 09 09 09 20 20 20 20 20 -hook")....
f530: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
f540: 70 20 6d 74 63 6f 6e 66 20 22 73 65 74 75 70 22 p mtconf "setup"
f550: 20 22 6e 6f 74 69 66 69 63 61 74 69 6f 6e 2d 68 "notification-h
f560: 6f 6f 6b 22 29 0a 09 09 09 20 20 20 20 20 20 20 ook")....
f570: 23 66 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f #f))). (commo
f580: 6e 3a 77 69 74 68 2d 71 75 65 75 65 2d 64 62 0a n:with-queue-db.
f590: 20 20 20 20 20 6d 74 63 6f 6e 66 0a 20 20 20 20 mtconf.
f5a0: 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 73 64 69 (lambda (pktsdi
f5b0: 72 73 20 70 6b 74 73 64 69 72 20 70 64 62 29 0a rs pktsdir pdb).
f5c0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 (let* ((r
f5d0: 67 63 6f 6e 66 64 61 74 20 28 66 69 6e 64 2d 61 gconfdat (find-a
f5e0: 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 nd-read-config (
f5f0: 63 6f 6e 63 20 74 6f 70 70 61 74 68 20 22 2f 72 conc toppath "/r
f600: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
f610: 22 29 29 29 0a 09 20 20 20 20 20 20 28 72 67 63 "))).. (rgc
f620: 6f 6e 66 20 20 20 20 28 63 61 72 20 72 67 63 6f onf (car rgco
f630: 6e 66 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 nfdat)).. (
f640: 61 72 65 61 73 20 20 20 20 20 28 63 6f 6e 66 69 areas (confi
f650: 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 6d gf:get-section m
f660: 74 63 6f 6e 66 20 22 61 72 65 61 73 22 29 29 0a tconf "areas")).
f670: 09 20 20 20 20 20 20 28 63 6f 6e 74 6f 75 72 73 . (contours
f680: 20 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 (configf:get-s
f690: 65 63 74 69 6f 6e 20 6d 74 63 6f 6e 66 20 22 63 ection mtconf "c
f6a0: 6f 6e 74 6f 75 72 73 22 29 29 0a 09 20 20 20 20 ontours"))..
f6b0: 20 20 28 70 6b 74 73 20 20 20 20 20 20 28 66 69 (pkts (fi
f6c0: 6e 64 2d 70 6b 74 73 20 70 64 62 20 27 28 63 6d nd-pkts pdb '(cm
f6d0: 64 29 20 27 28 29 29 29 0a 09 20 20 20 20 20 20 d) '()))..
f6e0: 28 74 6f 72 75 6e 20 20 20 20 20 28 6d 61 6b 65 (torun (make
f6f0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
f700: 20 74 61 72 67 65 74 20 3d 3e 20 28 20 2e 2e 2e target => ( ...
f710: 20 69 6e 66 6f 20 2e 2e 2e 20 29 0a 09 20 20 20 info ... )..
f720: 20 20 20 28 72 67 65 6e 74 61 72 67 73 20 28 68 (rgentargs (h
f730: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 72 ash-table-keys r
f740: 67 63 6f 6e 66 29 29 29 20 3b 3b 20 74 68 65 73 gconf))) ;; thes
f750: 65 20 61 72 65 20 74 68 65 20 74 61 72 67 65 74 e are the target
f760: 73 20 72 65 67 69 73 74 65 72 65 64 20 66 6f 72 s registered for
f770: 20 61 75 74 6f 6d 61 74 69 63 61 6c 6c 79 20 74 automatically t
f780: 72 69 67 67 65 72 69 6e 67 0a 20 20 20 20 20 20 riggering.
f790: 20 20 20 28 73 71 6c 69 74 65 33 3a 73 65 74 2d (sqlite3:set-
f7a0: 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 28 64 busy-handler! (d
f7b0: 62 69 3a 64 62 2d 63 6f 6e 6e 20 70 64 62 29 20 bi:db-conn pdb)
f7c0: 28 73 71 6c 69 74 65 33 3a 6d 61 6b 65 2d 62 75 (sqlite3:make-bu
f7d0: 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 30 sy-timeout 10000
f7e0: 29 29 0a 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 )).. (for-each..
f7f0: 20 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 64 61 (lambda (pktda
f800: 74 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 t).. (let* ((
f810: 70 6b 74 61 20 20 20 20 28 61 6c 69 73 74 2d 72 pkta (alist-r
f820: 65 66 20 27 61 70 6b 74 20 70 6b 74 64 61 74 29 ef 'apkt pktdat)
f830: 29 0a 09 09 20 20 20 28 61 63 74 69 6f 6e 20 20 )... (action
f840: 28 61 6c 69 73 74 2d 72 65 66 20 27 41 20 70 6b (alist-ref 'A pk
f850: 74 61 29 29 0a 09 09 20 20 20 28 63 6d 64 6c 69 ta))... (cmdli
f860: 6e 65 20 28 70 6b 74 2d 3e 63 6d 64 6c 69 6e 65 ne (pkt->cmdline
f870: 20 70 6b 74 61 29 29 0a 09 09 20 20 20 28 75 75 pkta))... (uu
f880: 69 64 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 id (alist-ref
f890: 20 27 5a 20 70 6b 74 61 29 29 0a 09 09 20 20 20 'Z pkta))...
f8a0: 28 75 73 65 72 20 20 20 20 28 61 6c 69 73 74 2d (user (alist-
f8b0: 72 65 66 20 27 55 20 70 6b 74 61 29 29 0a 09 09 ref 'U pkta))...
f8c0: 20 20 20 28 61 72 65 61 20 20 20 20 28 61 6c 69 (area (ali
f8d0: 73 74 2d 72 65 66 20 27 47 20 70 6b 74 61 29 29 st-ref 'G pkta))
f8e0: 0a 09 09 20 20 20 28 6c 6f 67 66 20 20 20 20 28 ... (logf (
f8f0: 63 6f 6e 63 20 6c 6f 67 64 69 72 20 22 2f 22 20 conc logdir "/"
f900: 75 75 69 64 20 22 2d 72 75 6e 2e 6c 6f 67 22 29 uuid "-run.log")
f910: 29 0a 09 09 20 20 20 28 70 6b 74 66 69 6c 65 20 )... (pktfile
f920: 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 2f (conc pktsdir "/
f930: 22 20 75 75 69 64 20 22 2e 70 6b 74 22 29 29 0a " uuid ".pkt")).
f940: 09 09 20 20 20 28 66 75 6c 6c 63 6d 64 20 28 63 .. (fullcmd (c
f950: 6f 6e 63 20 22 4e 42 46 41 4b 45 5f 4c 4f 47 3d onc "NBFAKE_LOG=
f960: 22 20 6c 6f 67 66 20 22 20 6e 62 66 61 6b 65 20 " logf " nbfake
f970: 22 20 63 6d 64 6c 69 6e 65 29 29 29 0a 09 20 20 " cmdline)))..
f980: 20 20 20 20 28 69 66 20 28 63 68 65 63 6b 2d 61 (if (check-a
f990: 63 63 65 73 73 20 75 73 65 72 20 6d 74 63 6f 6e ccess user mtcon
f9a0: 66 20 61 63 74 69 6f 6e 20 61 72 65 61 29 0a 09 f action area)..
f9b0: 09 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 63 . (if (and (> c
f9c0: 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 29 0a puload maxload).
f9d0: 09 09 09 20 20 20 28 6d 65 6d 62 65 72 20 61 63 ... (member ac
f9e0: 74 69 6f 6e 20 27 28 22 72 75 6e 22 20 22 61 72 tion '("run" "ar
f9f0: 63 68 69 76 65 22 29 29 29 20 3b 3b 20 64 6f 20 chive"))) ;; do
fa00: 6e 6f 74 20 72 75 6e 20 61 72 63 68 69 76 65 20 not run archive
fa10: 6f 72 20 72 75 6e 20 69 66 20 6c 6f 61 64 20 69 or run if load i
fa20: 73 20 6f 76 65 72 20 74 68 65 20 73 70 65 63 69 s over the speci
fa30: 66 69 65 64 20 6c 69 6d 69 74 0a 09 09 20 20 20 fied limit...
fa40: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 70 72 (begin....(pr
fa50: 69 6e 74 20 22 57 41 52 4e 49 4e 47 3a 20 63 70 int "WARNING: cp
fa60: 75 6c 6f 61 64 20 74 6f 6f 20 68 69 67 68 2c 20 uload too high,
fa70: 73 6b 69 70 70 69 6e 67 20 70 72 6f 63 65 73 73 skipping process
fa80: 69 6e 67 20 6f 66 20 22 20 75 75 69 64 20 22 20 ing of " uuid "
fa90: 64 75 65 20 74 6f 20 22 20 63 70 75 6c 6f 61 64 due to " cpuload
faa0: 20 22 20 3e 20 22 20 6d 61 78 6c 6f 61 64 29 0a " > " maxload).
fab0: 09 09 09 28 69 66 20 6e 6f 74 69 66 69 63 61 74 ...(if notificat
fac0: 69 6f 6e 2d 68 6f 6f 6b 0a 09 09 09 20 20 20 20 ion-hook....
fad0: 28 6c 65 74 2a 20 28 28 6e 6f 74 69 66 69 63 61 (let* ((notifica
fae0: 74 69 6f 6e 2d 63 6d 64 20 28 63 6f 6e 63 20 6e tion-cmd (conc n
faf0: 6f 74 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f 6b otification-hook
fb00: 20 22 20 2d 2d 70 6b 74 20 22 20 70 6b 74 66 69 " --pkt " pktfi
fb10: 6c 65 20 22 20 2d 2d 6d 73 67 20 48 49 47 48 5f le " --msg HIGH_
fb20: 4c 4f 41 44 22 29 29 29 0a 09 09 09 20 20 20 20 LOAD")))....
fb30: 20 20 28 70 72 69 6e 74 20 22 52 75 6e 6e 69 6e (print "Runnin
fb40: 67 20 22 20 6e 6f 74 69 66 69 63 61 74 69 6f 6e g " notification
fb50: 2d 63 6d 64 29 20 0a 09 09 09 20 20 20 20 20 20 -cmd) ....
fb60: 28 73 79 73 74 65 6d 20 6e 6f 74 69 66 69 63 61 (system notifica
fb70: 74 69 6f 6e 2d 63 6d 64 29 29 29 29 0a 09 09 20 tion-cmd))))...
fb80: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 3b (begin....;
fb90: 3b 20 69 66 20 6d 6f 64 65 70 61 74 74 20 75 73 ; if modepatt us
fba0: 65 64 20 63 68 65 6b 20 69 66 20 69 74 20 69 73 ed chek if it is
fbb0: 20 64 65 66 69 6e 65 64 20 66 6f 72 20 74 68 65 defined for the
fbc0: 20 74 61 72 67 65 74 2e 20 49 66 20 2d 72 65 71 target. If -req
fbd0: 74 61 72 67 20 63 68 65 63 6b 20 69 66 20 74 61 targ check if ta
fbe0: 72 67 65 74 20 65 78 69 73 74 2e 0a 09 09 09 28 rget exist.....(
fbf0: 69 66 20 28 76 61 6c 69 64 61 74 65 2d 63 6d 64 if (validate-cmd
fc00: 20 66 75 6c 6c 63 6d 64 20 70 6b 74 61 20 6e 6f fullcmd pkta no
fc10: 74 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f 6b 20 tification-hook
fc20: 70 6b 74 66 69 6c 65 29 0a 09 09 09 20 20 20 20 pktfile)....
fc30: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 (begin....
fc40: 28 70 72 69 6e 74 20 22 52 55 4e 4e 49 4e 47 3a (print "RUNNING:
fc50: 20 22 20 66 75 6c 6c 63 6d 64 29 0a 09 09 09 20 " fullcmd)....
fc60: 20 20 20 20 20 28 73 79 73 74 65 6d 20 66 75 6c (system ful
fc70: 6c 63 6d 64 29 20 3b 3b 20 72 65 70 6c 61 63 65 lcmd) ;; replace
fc80: 20 77 69 74 68 20 70 72 6f 63 65 73 73 20 2e 2e with process ..
fc90: 2e 0a 09 09 09 20 20 20 20 20 20 28 6d 61 72 6b ..... (mark
fca0: 2d 70 72 6f 63 65 73 73 65 64 20 70 64 62 20 28 -processed pdb (
fcb0: 6c 69 73 74 20 28 61 6c 69 73 74 2d 72 65 66 20 list (alist-ref
fcc0: 27 69 64 20 70 6b 74 64 61 74 29 29 29 0a 09 09 'id pktdat)))...
fcd0: 09 20 20 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 . (let-valu
fce0: 65 73 20 28 28 28 61 63 6b 2d 75 75 69 64 20 61 es (((ack-uuid a
fcf0: 63 6b 2d 70 6b 74 29 0a 09 09 09 09 09 20 20 20 ck-pkt)......
fd00: 20 28 61 64 64 2d 7a 2d 63 61 72 64 0a 09 09 09 (add-z-card....
fd10: 09 09 20 20 20 20 20 28 63 6f 6e 73 74 72 75 63 .. (construc
fd20: 74 2d 73 64 61 74 20 27 50 20 75 75 69 64 0a 09 t-sdat 'P uuid..
fd30: 09 09 09 09 09 09 20 20 20 20 20 27 54 20 28 63 ...... 'T (c
fd40: 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
fd50: 62 6f 6c 20 61 63 74 69 6f 6e 29 0a 09 09 09 09 bol action).....
fd60: 09 09 09 09 20 20 28 28 72 75 6e 29 20 22 72 75 .... ((run) "ru
fd70: 6e 73 74 61 72 74 22 29 0a 09 09 09 09 09 09 09 nstart")........
fd80: 09 20 20 28 28 73 79 6e 63 29 20 22 73 79 6e 63 . ((sync) "sync
fd90: 73 74 61 72 74 22 29 20 20 20 20 3b 3b 20 65 78 start") ;; ex
fda0: 61 6d 70 6c 65 20 6f 66 20 74 72 61 6e 73 6c 61 ample of transla
fdb0: 74 69 6e 67 20 72 75 6e 20 2d 3e 20 72 75 6e 73 ting run -> runs
fdc0: 74 61 72 74 0a 09 09 09 09 09 09 09 09 20 20 28 tart......... (
fdd0: 65 6c 73 65 20 20 20 61 63 74 69 6f 6e 29 29 0a else action)).
fde0: 09 09 09 09 09 09 09 20 20 20 20 20 27 47 20 28 ....... 'G (
fdf0: 61 6c 69 73 74 2d 72 65 66 20 27 47 20 70 6b 74 alist-ref 'G pkt
fe00: 61 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 27 a)........ '
fe10: 63 20 28 61 6c 69 73 74 2d 72 65 66 20 27 63 20 c (alist-ref 'c
fe20: 70 6b 74 61 29 20 3b 3b 20 54 48 49 53 20 49 53 pkta) ;; THIS IS
fe30: 20 57 52 4f 4e 47 21 20 53 48 4f 55 4c 44 20 42 WRONG! SHOULD B
fe40: 45 20 27 63 0a 09 09 09 09 09 09 09 20 20 20 20 E 'c........
fe50: 20 27 74 20 28 61 6c 69 73 74 2d 72 65 66 20 27 't (alist-ref '
fe60: 74 20 70 6b 74 61 29 29 29 29 29 0a 09 09 09 09 t pkta))))).....
fe70: 28 77 72 69 74 65 2d 70 6b 74 20 70 6b 74 73 64 (write-pkt pktsd
fe80: 69 72 20 61 63 6b 2d 75 75 69 64 20 61 63 6b 2d ir ack-uuid ack-
fe90: 70 6b 74 29 29 0a 09 09 09 20 20 20 20 20 20 28 pkt)).... (
fea0: 69 66 20 6e 6f 74 69 66 69 63 61 74 69 6f 6e 2d if notification-
feb0: 68 6f 6f 6b 0a 09 09 09 09 20 20 28 6c 65 74 2a hook..... (let*
fec0: 20 28 28 6e 6f 74 69 66 69 63 61 74 69 6f 6e 2d ((notification-
fed0: 63 6d 64 20 28 63 6f 6e 63 20 6e 6f 74 69 66 69 cmd (conc notifi
fee0: 63 61 74 69 6f 6e 2d 68 6f 6f 6b 20 22 20 2d 2d cation-hook " --
fef0: 70 6b 74 20 22 20 70 6b 74 66 69 6c 65 20 22 20 pkt " pktfile "
ff00: 2d 2d 6d 73 67 20 52 55 4e 5f 4c 41 55 4e 43 48 --msg RUN_LAUNCH
ff10: 45 44 20 2d 2d 63 6f 6e 74 6f 75 72 20 22 20 28 ED --contour " (
ff20: 63 61 61 72 20 20 63 6f 6e 74 6f 75 72 73 29 20 caar contours)
ff30: 22 20 2d 2d 6c 6f 67 5f 70 61 74 68 20 22 20 6c " --log_path " l
ff40: 6f 67 66 20 29 29 29 0a 09 09 09 09 20 20 20 20 ogf ))).....
ff50: 28 70 72 69 6e 74 20 22 52 75 6e 6e 69 6e 67 20 (print "Running
ff60: 22 20 6e 6f 74 69 66 69 63 61 74 69 6f 6e 2d 63 " notification-c
ff70: 6d 64 29 09 09 09 09 0a 09 09 09 09 20 20 20 20 md).........
ff80: 28 73 79 73 74 65 6d 20 6e 6f 74 69 66 69 63 61 (system notifica
ff90: 74 69 6f 6e 2d 63 6d 64 29 29 29 29 0a 09 09 09 tion-cmd))))....
ffa0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
ffb0: 20 20 20 20 28 6d 61 72 6b 2d 70 72 6f 63 65 73 (mark-proces
ffc0: 73 65 64 20 70 64 62 20 28 6c 69 73 74 20 28 61 sed pdb (list (a
ffd0: 6c 69 73 74 2d 72 65 66 20 27 69 64 20 70 6b 74 list-ref 'id pkt
ffe0: 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 dat)))....
fff0: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 61 (let-values (((a
10000 63 6b 2d 75 75 69 64 20 61 63 6b 2d 70 6b 74 29 ck-uuid ack-pkt)
10010 0a 09 09 09 09 09 20 20 20 20 28 61 64 64 2d 7a ...... (add-z
10020 2d 63 61 72 64 0a 09 09 09 09 09 20 20 20 20 20 -card......
10030 28 63 6f 6e 73 74 72 75 63 74 2d 73 64 61 74 20 (construct-sdat
10040 27 50 20 75 75 69 64 0a 09 09 09 09 09 09 09 20 'P uuid........
10050 20 20 20 20 27 54 20 22 69 6e 76 61 6c 69 64 2d 'T "invalid-
10060 69 6e 70 75 74 22 0a 09 09 09 09 09 09 09 20 20 input"........
10070 20 20 20 27 63 20 28 61 6c 69 73 74 2d 72 65 66 'c (alist-ref
10080 20 27 6f 20 70 6b 74 61 29 20 3b 3b 20 54 48 49 'o pkta) ;; THI
10090 53 20 49 53 20 57 52 4f 4e 47 21 20 53 48 4f 55 S IS WRONG! SHOU
100a0 4c 44 20 42 45 20 27 63 0a 09 09 09 09 09 09 09 LD BE 'c........
100b0 20 20 20 20 20 27 74 20 28 61 6c 69 73 74 2d 72 't (alist-r
100c0 65 66 20 27 74 20 70 6b 74 61 29 29 29 29 29 0a ef 't pkta))))).
100d0 09 09 09 09 28 77 72 69 74 65 2d 70 6b 74 20 70 ....(write-pkt p
100e0 6b 74 73 64 69 72 20 61 63 6b 2d 75 75 69 64 20 ktsdir ack-uuid
100f0 61 63 6b 2d 70 6b 74 29 29 29 29 29 29 0a 09 09 ack-pkt))))))...
10100 20 20 28 62 65 67 69 6e 20 3b 3b 20 61 63 63 65 (begin ;; acce
10110 73 73 20 64 65 6e 69 65 64 21 20 4d 61 72 6b 20 ss denied! Mark
10120 61 73 20 73 75 63 68 0a 09 09 20 20 20 20 28 6d as such... (m
10130 61 72 6b 2d 70 72 6f 63 65 73 73 65 64 20 70 64 ark-processed pd
10140 62 20 28 6c 69 73 74 20 28 61 6c 69 73 74 2d 72 b (list (alist-r
10150 65 66 20 27 69 64 20 70 6b 74 64 61 74 29 29 29 ef 'id pktdat)))
10160 0a 09 09 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 ... (let-valu
10170 65 73 20 28 28 28 61 63 6b 2d 75 75 69 64 20 61 es (((ack-uuid a
10180 63 6b 2d 70 6b 74 29 0a 09 09 09 09 20 20 28 61 ck-pkt)..... (a
10190 64 64 2d 7a 2d 63 61 72 64 0a 09 09 09 09 20 20 dd-z-card.....
101a0 20 28 63 6f 6e 73 74 72 75 63 74 2d 73 64 61 74 (construct-sdat
101b0 20 27 50 20 75 75 69 64 0a 09 09 09 09 09 09 20 'P uuid.......
101c0 20 20 27 54 20 22 61 63 63 65 73 73 2d 64 65 6e 'T "access-den
101d0 69 65 64 22 0a 09 09 09 09 09 09 20 20 20 27 63 ied"....... 'c
101e0 20 28 61 6c 69 73 74 2d 72 65 66 20 27 6f 20 70 (alist-ref 'o p
101f0 6b 74 61 29 20 3b 3b 20 54 48 49 53 20 49 53 20 kta) ;; THIS IS
10200 57 52 4f 4e 47 21 20 53 48 4f 55 4c 44 20 42 45 WRONG! SHOULD BE
10210 20 27 63 0a 09 09 09 09 09 09 20 20 20 27 74 20 'c....... 't
10220 28 61 6c 69 73 74 2d 72 65 66 20 27 74 20 70 6b (alist-ref 't pk
10230 74 61 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 ta)))))...
10240 28 77 72 69 74 65 2d 70 6b 74 20 70 6b 74 73 64 (write-pkt pktsd
10250 69 72 20 61 63 6b 2d 75 75 69 64 20 61 63 6b 2d ir ack-uuid ack-
10260 70 6b 74 29 29 0a 09 09 20 20 20 20 28 69 66 20 pkt))... (if
10270 6e 6f 74 69 66 69 63 61 74 69 6f 6e 2d 68 6f 6f notification-hoo
10280 6b 0a 09 09 09 28 6c 65 74 2a 20 28 28 6e 6f 74 k....(let* ((not
10290 69 66 69 63 61 74 69 6f 6e 2d 63 6d 64 20 28 63 ification-cmd (c
102a0 6f 6e 63 20 6e 6f 74 69 66 69 63 61 74 69 6f 6e onc notification
102b0 2d 68 6f 6f 6b 20 22 20 2d 2d 70 6b 74 20 22 20 -hook " --pkt "
102c0 70 6b 74 66 69 6c 65 20 22 20 2d 2d 6d 73 67 20 pktfile " --msg
102d0 41 43 43 45 53 53 5f 44 45 4e 49 45 44 22 29 29 ACCESS_DENIED"))
102e0 29 0a 09 09 09 20 20 28 70 72 69 6e 74 20 22 52 ).... (print "R
102f0 75 6e 6e 69 6e 67 20 22 20 6e 6f 74 69 66 69 63 unning " notific
10300 61 74 69 6f 6e 2d 63 6d 64 29 0a 09 09 09 20 20 ation-cmd)....
10310 28 73 79 73 74 65 6d 20 6e 6f 74 69 66 69 63 61 (system notifica
10320 74 69 6f 6e 2d 63 6d 64 29 29 29 29 29 29 29 0a tion-cmd))))))).
10330 09 20 20 70 6b 74 73 29 29 29 29 29 29 0a 0a 0a . pkts))))))...
10340 28 64 65 66 69 6e 65 20 28 63 68 65 63 6b 2d 61 (define (check-a
10350 63 63 65 73 73 20 75 73 65 72 20 6d 74 63 6f 6e ccess user mtcon
10360 66 20 61 63 74 69 6f 6e 20 61 72 65 61 29 0a 20 f action area).
10370 20 3b 3b 20 4e 4f 54 45 3a 20 4e 65 65 64 20 63 ;; NOTE: Need c
10380 6f 6e 74 72 6f 6c 20 6f 76 65 72 20 64 65 66 61 ontrol over defa
10390 75 6c 74 73 2e 20 45 2e 67 2e 20 64 65 66 61 75 ults. E.g. defau
103a0 6c 74 20 6d 69 67 68 74 20 62 65 20 6e 6f 20 61 lt might be no a
103b0 63 63 65 73 73 0a 20 20 28 6c 65 74 2a 20 28 28 ccess. (let* ((
103c0 61 63 63 65 73 73 2d 63 74 72 6c 20 28 68 61 73 access-ctrl (has
103d0 68 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 3f 20 h-table-exists?
103e0 6d 74 63 6f 6e 66 20 22 61 63 63 65 73 73 22 29 mtconf "access")
103f0 29 20 20 3b 3b 20 69 66 20 74 68 65 72 65 20 69 ) ;; if there i
10400 73 20 61 6e 20 61 63 63 65 73 73 20 73 65 63 74 s an access sect
10410 69 6f 6e 20 74 68 65 20 64 65 66 61 75 6c 74 20 ion the default
10420 69 73 20 74 6f 20 52 45 51 55 49 52 45 20 65 6e is to REQUIRE en
10430 61 62 6c 65 6d 65 6e 74 2f 61 63 63 65 73 73 0a ablement/access.
10440 09 20 28 61 63 63 65 73 73 2d 6c 69 73 74 20 28 . (access-list (
10450 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
10460 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
10470 73 70 6c 69 74 20 78 20 22 3a 22 29 29 0a 09 09 split x ":"))...
10480 09 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 . (string-spli
10490 74 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c t (or (configf:l
104a0 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 61 63 ookup mtconf "ac
104b0 63 65 73 73 22 20 61 72 65 61 29 20 3b 3b 20 75 cess" area) ;; u
104c0 73 65 72 69 64 3a 72 69 67 68 74 73 74 79 70 65 serid:rightstype
104d0 20 75 73 65 72 69 64 32 3a 72 69 67 68 74 73 74 userid2:rightst
104e0 79 70 65 32 20 2e 2e 2e 0a 09 09 09 09 09 20 20 ype2 .........
104f0 20 20 20 28 69 66 20 61 63 63 65 73 73 2d 63 74 (if access-ct
10500 72 6c 0a 09 09 09 09 09 09 20 22 2a 3a 6e 6f 6e rl....... "*:non
10510 65 22 20 20 3b 3b 20 6e 6f 62 6f 64 79 20 68 61 e" ;; nobody ha
10520 73 20 61 63 63 65 73 73 20 62 79 20 64 65 66 61 s access by defa
10530 75 6c 74 0a 09 09 09 09 09 09 20 22 2a 3a 61 6c ult....... "*:al
10540 6c 22 29 29 29 29 29 0a 09 20 28 61 63 63 65 73 l"))))).. (acces
10550 73 2d 74 79 70 65 73 2d 64 61 74 20 28 63 6f 6e s-types-dat (con
10560 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e figf:get-section
10570 20 6d 74 63 6f 6e 66 20 22 61 63 63 65 73 73 74 mtconf "accesst
10580 79 70 65 73 22 29 29 29 0a 20 20 20 20 28 64 65 ypes"))). (de
10590 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 bug:print 2 *def
105a0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
105b0 43 68 65 63 6b 69 6e 67 20 61 63 63 65 73 73 20 Checking access
105c0 69 6e 20 22 20 61 63 63 65 73 73 2d 6c 69 73 74 in " access-list
105d0 20 22 20 77 69 74 68 20 61 63 63 65 73 73 2d 63 " with access-c
105e0 74 72 6c 20 22 20 61 63 63 65 73 73 2d 63 74 72 trl " access-ctr
105f0 6c 20 22 20 66 6f 72 20 61 72 65 61 20 22 20 61 l " for area " a
10600 72 65 61 29 0a 20 20 20 20 28 69 66 20 61 63 63 rea). (if acc
10610 65 73 73 2d 63 74 72 6c 0a 09 28 6c 65 74 2a 20 ess-ctrl..(let*
10620 28 28 75 73 65 72 2d 61 63 63 65 73 73 20 20 20 ((user-access
10630 20 20 28 6f 72 20 28 61 73 73 6f 63 20 75 73 65 (or (assoc use
10640 72 20 61 63 63 65 73 73 2d 6c 69 73 74 29 0a 09 r access-list)..
10650 09 09 09 20 20 20 20 28 61 73 73 6f 63 20 22 2a ... (assoc "*
10660 22 20 20 61 63 63 65 73 73 2d 6c 69 73 74 29 29 " access-list))
10670 29 0a 09 20 20 20 20 20 20 20 28 61 63 63 65 73 ).. (acces
10680 73 2d 74 79 70 65 20 20 20 28 69 66 20 75 73 65 s-type (if use
10690 72 2d 61 63 63 65 73 73 0a 09 09 09 09 09 09 09 r-access........
106a0 09 09 09 09 09 20 20 28 63 61 64 72 20 75 73 65 ..... (cadr use
106b0 72 2d 61 63 63 65 73 73 29 0a 20 20 20 20 20 20 r-access).
106c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
106d0 20 20 20 20 20 23 66 29 29 0a 09 20 20 20 20 20 #f))..
106e0 20 20 28 61 63 63 65 73 73 2d 74 79 70 65 73 20 (access-types
106f0 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 61 (let ((res (a
10700 6c 69 73 74 2d 72 65 66 20 61 63 63 65 73 73 2d list-ref access-
10710 74 79 70 65 20 61 63 63 65 73 73 2d 74 79 70 65 type access-type
10720 73 2d 64 61 74 20 65 71 75 61 6c 3f 29 29 29 0a s-dat equal?))).
10730 09 09 09 09 20 20 28 69 66 20 72 65 73 20 28 63 .... (if res (c
10740 61 72 20 72 65 73 29 20 72 65 73 29 29 29 0a 09 ar res) res)))..
10750 20 20 20 20 20 20 20 28 61 6c 6c 6f 77 65 64 2d (allowed-
10760 61 63 74 69 6f 6e 73 20 28 73 74 72 69 6e 67 2d actions (string-
10770 73 70 6c 69 74 20 28 6f 72 20 61 63 63 65 73 73 split (or access
10780 2d 74 79 70 65 73 20 22 22 29 29 29 29 0a 09 20 -types ""))))..
10790 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
107a0 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
107b0 74 2a 20 22 47 6f 74 20 22 20 61 6c 6c 6f 77 65 t* "Got " allowe
107c0 64 2d 61 63 74 69 6f 6e 73 20 22 20 66 6f 72 20 d-actions " for
107d0 75 73 65 72 20 22 20 75 73 65 72 20 22 20 77 68 user " user " wh
107e0 65 72 65 20 61 63 63 65 73 73 2d 74 79 70 65 73 ere access-types
107f0 3d 22 20 61 63 63 65 73 73 2d 74 79 70 65 73 20 =" access-types
10800 22 20 61 63 63 65 73 73 2d 74 79 70 65 3d 22 20 " access-type="
10810 61 63 63 65 73 73 2d 74 79 70 65 29 0a 09 20 20 access-type)..
10820 28 63 6f 6e 64 0a 09 20 20 20 28 28 61 6e 64 20 (cond.. ((and
10830 61 63 63 65 73 73 2d 74 79 70 65 73 20 28 6d 65 access-types (me
10840 6d 62 65 72 20 61 63 74 69 6f 6e 20 61 6c 6c 6f mber action allo
10850 77 65 64 2d 61 63 74 69 6f 6e 73 29 29 0a 09 20 wed-actions))..
10860 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 41 63 ;; (print "Ac
10870 63 65 73 73 20 67 72 61 6e 74 65 64 20 66 6f 72 cess granted for
10880 20 22 20 75 73 65 72 20 22 20 66 6f 72 20 22 20 " user " for "
10890 61 63 74 69 6f 6e 29 0a 09 20 20 20 20 23 74 29 action).. #t)
108a0 0a 09 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 .. (else..
108b0 3b 3b 20 28 70 72 69 6e 74 20 22 41 63 63 65 73 ;; (print "Acces
108c0 73 20 64 65 6e 69 65 64 20 66 6f 72 20 22 20 75 s denied for " u
108d0 73 65 72 20 22 20 66 6f 72 20 22 20 61 63 74 69 ser " for " acti
108e0 6f 6e 29 0a 09 20 20 20 20 23 66 29 29 29 29 29 on).. #f)))))
108f0 29 0a 0a 28 64 65 66 69 6e 65 20 28 6f 70 65 6e )..(define (open
10900 2d 6c 6f 67 66 69 6c 65 20 6c 6f 67 70 61 74 68 -logfile logpath
10910 29 0a 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 ). (condition-c
10920 61 73 65 0a 20 20 20 28 6c 65 74 2a 20 28 28 6c ase. (let* ((l
10930 6f 67 2d 64 69 72 20 28 6f 72 20 28 70 61 74 68 og-dir (or (path
10940 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 6c name-directory l
10950 6f 67 70 61 74 68 29 20 22 2e 22 29 29 29 0a 20 ogpath) "."))).
10960 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 64 69 (if (not (di
10970 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 rectory-exists?
10980 6c 6f 67 2d 64 69 72 29 29 0a 20 20 20 20 20 20 log-dir)).
10990 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (system (conc
109a0 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6c 6f 67 "mkdir -p " log
109b0 2d 64 69 72 29 29 29 0a 20 20 20 20 20 28 6f 70 -dir))). (op
109c0 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 6c en-output-file l
109d0 6f 67 70 61 74 68 29 29 0a 20 20 20 28 65 78 6e ogpath)). (exn
109e0 20 28 29 0a 20 20 20 20 20 20 20 20 28 64 65 62 (). (deb
109f0 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
10a00 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
10a10 72 74 2a 20 22 43 6f 75 6c 64 20 6e 6f 74 20 6f rt* "Could not o
10a20 70 65 6e 20 6c 6f 67 20 66 69 6c 65 20 66 6f 72 pen log file for
10a30 20 77 72 69 74 65 3a 20 22 6c 6f 67 70 61 74 68 write: "logpath
10a40 29 0a 20 20 20 20 20 20 20 20 28 64 65 66 69 6e ). (defin
10a50 65 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a e *didsomething*
10a60 20 23 74 29 20 20 0a 20 20 20 20 20 20 20 20 28 #t) . (
10a70 65 78 69 74 20 31 29 29 29 29 0a 0a 0a 28 64 65 exit 1))))...(de
10a80 66 69 6e 65 20 28 67 65 74 2d 70 6b 74 73 2d 64 fine (get-pkts-d
10a90 69 72 20 6d 74 63 6f 6e 66 29 0a 20 20 28 6c 65 ir mtconf). (le
10aa0 74 20 28 28 70 6b 74 73 64 69 72 73 20 20 28 63 t ((pktsdirs (c
10ab0 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 onfigf:lookup mt
10ac0 63 6f 6e 66 20 22 73 65 74 75 70 22 20 22 70 6b conf "setup" "pk
10ad0 74 73 64 69 72 73 22 29 29 0a 09 28 70 6b 74 73 tsdirs"))..(pkts
10ae0 64 69 72 20 20 20 28 69 66 20 70 6b 74 73 64 69 dir (if pktsdi
10af0 72 73 20 28 63 61 72 20 28 73 74 72 69 6e 67 2d rs (car (string-
10b00 73 70 6c 69 74 20 70 6b 74 73 64 69 72 73 20 22 split pktsdirs "
10b10 20 22 29 29 20 23 66 29 29 29 0a 20 20 20 20 70 ")) #f))). p
10b20 6b 74 73 64 69 72 29 29 0a 0a 28 6c 65 74 20 28 ktsdir))..(let (
10b30 28 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 20 28 (debugcontrolf (
10b40 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f conc (get-enviro
10b50 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
10b60 48 4f 4d 45 22 29 20 22 2f 2e 6d 74 75 74 69 6c HOME") "/.mtutil
10b70 72 63 22 29 29 29 0a 20 20 28 69 66 20 28 63 6f rc"))). (if (co
10b80 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
10b90 3f 20 64 65 62 75 67 63 6f 6e 74 72 6f 6c 66 29 ? debugcontrolf)
10ba0 0a 20 20 20 20 20 20 28 6c 6f 61 64 20 64 65 62 . (load deb
10bb0 75 67 63 6f 6e 74 72 6f 6c 66 29 29 29 0a 0a 28 ugcontrolf)))..(
10bc0 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
10bd0 20 22 2d 6c 6f 67 22 29 20 3b 3b 20 72 65 64 69 "-log") ;; redi
10be0 72 65 63 74 20 74 68 65 20 6c 6f 67 20 61 6c 77 rect the log alw
10bf0 61 79 73 20 77 68 65 6e 20 61 20 73 65 72 76 65 ays when a serve
10c00 72 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 r. (handle-ex
10c10 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 ceptions..exn..(
10c20 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 begin.. (print
10c30 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 "ERROR: Failed t
10c40 6f 20 73 77 69 74 63 68 20 74 6f 20 6c 6f 67 20 o switch to log
10c50 6f 75 74 70 75 74 2e 20 22 20 28 28 63 6f 6e 64 output. " ((cond
10c60 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
10c70 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
10c80 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 ssage) exn))..
10c90 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ). (let* ((
10ca0 74 6c 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 tl (args:get-a
10cb0 72 67 20 22 2d 6c 6f 67 22 29 29 20 20 20 3b 3b rg "-log")) ;;
10cc0 20 72 75 6e 20 6c 61 75 6e 63 68 3a 73 65 74 75 run launch:setu
10cd0 70 20 69 66 20 2d 73 65 72 76 65 72 2c 20 65 6e p if -server, en
10ce0 73 75 72 65 20 77 65 20 64 6f 20 4e 4f 54 20 72 sure we do NOT r
10cf0 75 6e 20 6c 61 75 6e 63 68 3a 73 65 74 75 70 20 un launch:setup
10d00 69 66 20 2d 6c 6f 67 20 73 70 65 63 69 66 69 65 if -log specifie
10d10 64 0a 09 20 20 20 20 20 28 6c 6f 67 66 20 28 61 d.. (logf (a
10d20 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6c 6f rgs:get-arg "-lo
10d30 67 22 29 29 20 3b 3b 20 75 73 65 20 2d 6c 6f 67 g")) ;; use -log
10d40 20 75 6e 6c 65 73 73 20 77 65 20 61 72 65 20 61 unless we are a
10d50 20 73 65 72 76 65 72 2c 20 74 68 65 6e 20 63 72 server, then cr
10d60 61 66 74 20 61 20 6c 6f 67 66 69 6c 65 20 6e 61 aft a logfile na
10d70 6d 65 0a 09 20 20 20 20 20 28 6f 75 70 20 20 28 me.. (oup (
10d80 6f 70 65 6e 2d 6c 6f 67 66 69 6c 65 20 6c 6f 67 open-logfile log
10d90 66 29 29 29 0a 09 3b 28 69 66 20 28 6e 6f 74 20 f)))..;(if (not
10da0 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
10db0 6c 6f 67 22 29 29 0a 09 3b 20 20 20 20 28 68 61 log"))..; (ha
10dc0 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 61 72 sh-table-set! ar
10dd0 67 73 3a 61 72 67 2d 68 61 73 68 20 22 2d 6c 6f gs:arg-hash "-lo
10de0 67 22 20 6c 6f 67 66 29 29 20 3b 3b 20 66 61 6b g" logf)) ;; fak
10df0 65 20 6f 75 74 20 66 75 74 75 72 65 20 71 75 65 e out future que
10e00 72 69 65 73 20 6f 66 20 2d 6c 6f 67 0a 09 28 70 ries of -log..(p
10e10 72 69 6e 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f rint *default-lo
10e20 67 2d 70 6f 72 74 2a 20 22 53 65 6e 64 69 6e 67 g-port* "Sending
10e30 20 6c 6f 67 20 6f 75 74 70 75 74 20 74 6f 20 22 log output to "
10e40 20 6c 6f 67 66 29 0a 09 28 73 65 74 21 20 2a 64 logf)..(set! *d
10e50 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
10e60 20 6f 75 70 29 0a 29 29 29 0a 0a 28 69 66 20 2a oup).)))..(if *
10e70 61 63 74 69 6f 6e 2a 0a 20 20 20 20 28 63 61 73 action*. (cas
10e80 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
10e90 6c 20 2a 61 63 74 69 6f 6e 2a 29 0a 20 20 20 20 l *action*).
10ea0 20 20 28 28 72 75 6e 20 72 65 6d 6f 76 65 20 72 ((run remove r
10eb0 65 72 75 6e 20 72 65 72 75 6e 2d 63 6c 65 61 6e erun rerun-clean
10ec0 20 72 65 72 75 6e 2d 61 6c 6c 20 73 65 74 2d 73 rerun-all set-s
10ed0 73 20 61 72 63 68 69 76 65 20 6b 69 6c 6c 20 6c s archive kill l
10ee0 69 73 74 20 6b 69 6c 6c 2d 72 75 6e 20 6b 69 6c ist kill-run kil
10ef0 6c 2d 72 65 72 75 6e 20 6c 6f 63 6b 20 75 6e 6c l-rerun lock unl
10f00 6f 63 6b 29 0a 20 20 20 20 20 20 20 20 20 20 0a ock). .
10f10 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6d (let* ((m
10f20 74 63 6f 6e 66 64 61 74 20 28 73 69 6d 70 6c 65 tconfdat (simple
10f30 2d 73 65 74 75 70 20 28 61 72 67 73 3a 67 65 74 -setup (args:get
10f40 2d 61 72 67 20 22 2d 73 74 61 72 74 2d 64 69 72 -arg "-start-dir
10f50 22 29 29 29 0a 09 20 20 20 20 20 20 28 6d 74 63 "))).. (mtc
10f60 6f 6e 66 20 20 20 20 28 63 61 72 20 6d 74 63 6f onf (car mtco
10f70 6e 66 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 nfdat)).. (
10f80 61 72 65 61 20 20 20 20 20 20 28 61 72 67 73 3a area (args:
10f90 67 65 74 2d 61 72 67 20 22 2d 61 72 65 61 22 29 get-arg "-area")
10fa0 29 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 74 68 65 ) ;; look up the
10fb0 20 61 72 65 61 20 74 6f 20 64 69 73 70 61 74 63 area to dispatc
10fc0 68 20 74 6f 20 66 72 6f 6d 20 5b 61 72 65 61 73 h to from [areas
10fd0 5d 20 73 65 63 74 69 6f 6e 0a 09 20 20 20 20 20 ] section..
10fe0 20 28 61 72 65 61 73 65 63 20 20 20 28 69 66 20 (areasec (if
10ff0 61 72 65 61 20 28 63 6f 6e 66 69 67 66 3a 6c 6f area (configf:lo
11000 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 61 72 65 okup mtconf "are
11010 61 73 22 20 61 72 65 61 29 20 23 66 29 29 0a 09 as" area) #f))..
11020 20 20 20 20 20 20 28 61 72 65 61 64 61 74 20 20 (areadat
11030 20 28 69 66 20 61 72 65 61 73 65 63 20 28 63 6f (if areasec (co
11040 6d 6d 6f 6e 3a 76 61 6c 2d 3e 61 6c 69 73 74 20 mmon:val->alist
11050 61 72 65 61 73 65 63 29 20 23 66 29 29 0a 09 20 areasec) #f))..
11060 20 20 20 20 20 28 61 72 65 61 2d 70 61 74 68 20 (area-path
11070 28 69 66 20 61 72 65 61 64 61 74 20 28 61 6c 69 (if areadat (ali
11080 73 74 2d 72 65 66 20 27 70 61 74 68 20 61 72 65 st-ref 'path are
11090 61 64 61 74 29 20 23 66 29 29 0a 09 20 20 20 20 adat) #f))..
110a0 20 20 28 70 6b 74 73 64 69 72 73 20 20 28 63 6f (pktsdirs (co
110b0 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 nfigf:lookup mtc
110c0 6f 6e 66 20 22 73 65 74 75 70 22 20 22 70 6b 74 onf "setup" "pkt
110d0 73 64 69 72 73 22 29 29 0a 09 20 20 20 20 20 20 sdirs"))..
110e0 28 70 6b 74 73 64 69 72 20 20 20 28 69 66 20 70 (pktsdir (if p
110f0 6b 74 73 64 69 72 73 20 28 63 61 72 20 28 73 74 ktsdirs (car (st
11100 72 69 6e 67 2d 73 70 6c 69 74 20 70 6b 74 73 64 ring-split pktsd
11110 69 72 73 20 22 20 22 29 29 20 23 66 29 29 0a 09 irs " ")) #f))..
11120 20 20 20 20 20 20 28 61 64 6a 61 72 67 73 20 20 (adjargs
11130 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 63 6f 70 (hash-table-cop
11140 79 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 y args:arg-hash)
11150 29 0a 09 20 20 20 20 20 20 28 6e 65 77 2d 73 73 ).. (new-ss
11160 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
11170 67 20 22 2d 6e 65 77 22 29 29 29 0a 09 20 3b 3b g "-new"))).. ;;
11180 20 63 68 65 63 6b 20 61 20 66 65 77 20 74 68 69 check a few thi
11190 6e 67 73 0a 09 20 28 63 6f 6e 64 0a 09 20 20 28 ngs.. (cond.. (
111a0 28 61 6e 64 20 61 72 65 61 20 28 6e 6f 74 20 61 (and area (not a
111b0 72 65 61 2d 70 61 74 68 29 29 0a 09 20 20 20 28 rea-path)).. (
111c0 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 74 68 print "ERROR: th
111d0 65 20 73 70 65 63 69 66 69 65 64 20 61 72 65 61 e specified area
111e0 20 77 61 73 20 6e 6f 74 20 66 6f 75 6e 64 20 69 was not found i
111f0 6e 20 74 68 65 20 5b 61 72 65 61 73 5d 20 74 61 n the [areas] ta
11200 62 6c 65 2e 20 41 72 65 61 20 6e 61 6d 65 3d 22 ble. Area name="
11210 20 61 72 65 61 29 0a 09 20 20 20 28 65 78 69 74 area).. (exit
11220 20 31 29 29 0a 09 20 20 28 28 6e 6f 74 20 61 72 1)).. ((not ar
11230 65 61 29 0a 09 20 20 20 28 70 72 69 6e 74 20 22 ea).. (print "
11240 45 52 52 4f 52 3a 20 6e 6f 20 61 72 65 61 20 73 ERROR: no area s
11250 70 65 63 69 66 69 65 64 2e 20 55 73 65 20 2d 61 pecified. Use -a
11260 72 65 61 20 3c 61 72 65 61 6e 61 6d 65 3e 22 29 rea <areaname>")
11270 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 .. (exit 1))..
11280 20 20 28 65 6c 73 65 0a 09 20 20 20 28 6c 65 74 (else.. (let
11290 2a 20 28 28 75 73 72 2d 61 64 6d 69 6e 20 28 63 * ((usr-admin (c
112a0 68 65 63 6b 2d 61 63 63 65 73 73 20 28 63 75 72 heck-access (cur
112b0 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 rent-user-name)
112c0 6d 74 63 6f 6e 66 20 22 6f 76 65 72 72 69 64 65 mtconf "override
112d0 22 20 61 72 65 61 29 29 0a 09 09 09 09 09 28 75 " area))......(u
112e0 73 65 72 20 28 69 66 20 28 61 6e 64 20 75 73 72 ser (if (and usr
112f0 2d 61 64 6d 69 6e 20 28 61 72 67 73 3a 67 65 74 -admin (args:get
11300 2d 61 72 67 20 22 2d 6f 76 65 72 72 69 64 65 2d -arg "-override-
11310 75 73 65 72 22 29 29 0a 20 20 20 20 20 20 20 20 user")).
11320 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 (arg
11330 73 3a 67 65 74 2d 61 72 67 20 22 2d 6f 76 65 72 s:get-arg "-over
11340 72 69 64 65 2d 75 73 65 72 22 29 0a 09 09 09 09 ride-user").....
11350 09 09 09 09 09 20 20 28 63 75 72 72 65 6e 74 2d ..... (current-
11360 75 73 65 72 2d 6e 61 6d 65 29 29 29 29 0a 20 20 user-name)))).
11370 20 20 20 20 20 3b 20 28 70 72 69 6e 74 20 22 75 ; (print "u
11380 73 65 72 20 31 32 33 20 22 20 75 73 72 2d 61 64 ser 123 " usr-ad
11390 6d 69 6e 20 29 0a 20 20 20 20 20 20 20 20 3b 28 min ). ;(
113a0 65 78 69 74 20 31 29 0a 20 20 20 20 20 28 69 66 exit 1). (if
113b0 20 28 61 6e 64 20 28 6e 6f 74 20 75 73 72 2d 61 (and (not usr-a
113c0 64 6d 69 6e 29 20 28 61 72 67 73 3a 67 65 74 2d dmin) (args:get-
113d0 61 72 67 20 22 2d 6f 76 65 72 72 69 64 65 2d 75 arg "-override-u
113e0 73 65 72 22 29 29 0a 20 20 20 20 20 20 20 20 20 ser")).
113f0 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
11400 20 20 20 28 70 72 69 6e 74 20 20 75 73 65 72 20 (print user
11410 22 20 64 6f 65 73 20 6e 6f 74 20 68 61 76 65 20 " does not have
11420 61 63 63 65 73 73 20 74 6f 20 6f 76 65 72 72 69 access to overri
11430 64 65 20 75 73 65 72 22 29 0a 20 20 20 20 20 20 de user").
11440 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
11450 20 20 20 28 69 66 20 28 63 68 65 63 6b 2d 61 63 (if (check-ac
11460 63 65 73 73 20 75 73 65 72 20 6d 74 63 6f 6e 66 cess user mtconf
11470 20 2a 61 63 74 69 6f 6e 2a 20 61 72 65 61 29 3b *action* area);
11480 3b 20 63 68 65 63 6b 20 72 69 67 68 74 73 0a 09 ; check rights..
11490 09 20 28 70 72 69 6e 74 20 22 41 63 63 65 73 73 . (print "Access
114a0 20 67 72 61 6e 74 65 64 20 66 6f 72 20 22 20 2a granted for " *
114b0 61 63 74 69 6f 6e 2a 20 22 20 61 63 74 69 6f 6e action* " action
114c0 20 62 79 20 22 20 75 73 65 72 29 0a 09 09 20 28 by " user)... (
114d0 62 65 67 69 6e 0a 09 09 20 20 20 28 70 72 69 6e begin... (prin
114e0 74 20 22 41 63 63 65 73 73 20 64 65 6e 69 65 64 t "Access denied
114f0 20 66 6f 72 20 22 20 2a 61 63 74 69 6f 6e 2a 20 for " *action*
11500 22 20 61 63 74 69 6f 6e 20 62 79 20 22 20 75 73 " action by " us
11510 65 72 29 0a 09 09 20 20 20 28 65 78 69 74 20 31 er)... (exit 1
11520 29 29 29 29 29 29 0a 09 20 0a 09 20 3b 3b 20 28 )))))).. .. ;; (
11530 66 6f 72 2d 65 61 63 68 0a 09 20 3b 3b 20 20 28 for-each.. ;; (
11540 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 20 3b lambda (key).. ;
11550 3b 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6d ; (if (not (m
11560 65 6d 62 65 72 20 6b 65 79 20 2a 6c 65 67 61 6c ember key *legal
11570 2d 70 61 72 61 6d 73 2a 29 29 0a 09 20 3b 3b 20 -params*)).. ;;
11580 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c .(hash-table-del
11590 65 74 65 21 20 61 64 6a 61 72 67 73 20 6b 65 79 ete! adjargs key
115a0 29 29 29 20 3b 3b 20 77 65 20 6e 65 65 64 20 74 ))) ;; we need t
115b0 6f 20 64 65 6c 65 74 65 20 61 6e 79 20 70 61 72 o delete any par
115c0 61 6d 73 20 69 6e 74 65 6e 64 65 64 20 66 6f 72 ams intended for
115d0 20 6d 74 75 74 69 6c 0a 09 20 3b 3b 20 20 28 68 mtutil.. ;; (h
115e0 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 61 ash-table-keys a
115f0 64 6a 61 72 67 73 29 29 0a 09 20 28 6c 65 74 2d djargs)).. (let-
11600 76 61 6c 75 65 73 20 28 28 28 75 75 69 64 20 70 values (((uuid p
11610 6b 74 29 0a 09 09 20 20 20 20 20 20 20 28 63 6f kt)... (co
11620 6d 6d 61 6e 64 2d 6c 69 6e 65 2d 3e 70 6b 74 20 mmand-line->pkt
11630 2a 61 63 74 69 6f 6e 2a 20 61 64 6a 61 72 67 73 *action* adjargs
11640 20 23 66 20 61 72 65 61 2d 70 61 74 68 3a 20 61 #f area-path: a
11650 72 65 61 2d 70 61 74 68 20 6e 65 77 2d 73 73 3a rea-path new-ss:
11660 20 6e 65 77 2d 73 73 29 29 29 0a 20 20 20 20 20 new-ss))).
11670 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 72 75 (print "ru
11680 6e 20 6c 6f 67 20 40 20 22 20 28 63 6f 6e 63 20 n log @ " (conc
11690 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f (current-directo
116a0 72 79 29 20 22 2f 22 20 75 75 69 64 20 22 2d 22 ry) "/" uuid "-"
116b0 20 2a 61 63 74 69 6f 6e 2a 20 22 2e 6c 6f 67 22 *action* ".log"
116c0 29 29 0a 09 20 20 20 28 77 72 69 74 65 2d 70 6b )).. (write-pk
116d0 74 20 70 6b 74 73 64 69 72 20 75 75 69 64 20 70 t pktsdir uuid p
116e0 6b 74 29 29 29 29 0a 20 20 20 20 20 20 28 28 64 kt)))). ((d
116f0 69 73 70 61 74 63 68 20 69 6d 70 6f 72 74 20 72 ispatch import r
11700 75 6e 67 65 6e 20 70 72 6f 63 65 73 73 29 0a 20 ungen process).
11710 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 74 (let* ((mt
11720 63 6f 6e 66 64 61 74 20 28 73 69 6d 70 6c 65 2d confdat (simple-
11730 73 65 74 75 70 20 28 61 72 67 73 3a 67 65 74 2d setup (args:get-
11740 61 72 67 20 22 2d 73 74 61 72 74 2d 64 69 72 22 arg "-start-dir"
11750 29 29 29 0a 09 20 20 20 20 20 20 28 6d 74 63 6f ))).. (mtco
11760 6e 66 20 20 20 20 28 63 61 72 20 6d 74 63 6f 6e nf (car mtcon
11770 66 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 74 fdat)).. (t
11780 6f 70 70 61 74 68 20 20 20 28 63 6f 6e 66 69 67 oppath (config
11790 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 f:lookup mtconf
117a0 22 73 63 72 61 74 63 68 64 61 74 22 20 22 74 6f "scratchdat" "to
117b0 70 70 61 74 68 22 29 29 29 0a 09 20 28 63 61 73 ppath"))).. (cas
117c0 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
117d0 6c 20 2a 61 63 74 69 6f 6e 2a 29 0a 09 20 20 20 l *action*)..
117e0 28 28 70 72 6f 63 65 73 73 29 20 20 28 62 65 67 ((process) (beg
117f0 69 6e 0a 09 09 09 20 28 63 6f 6d 6d 6f 6e 3a 6c in.... (common:l
11800 6f 61 64 2d 70 6b 74 73 2d 74 6f 2d 64 62 20 6d oad-pkts-to-db m
11810 74 63 6f 6e 66 29 0a 09 09 09 20 28 67 65 6e 65 tconf).... (gene
11820 72 61 74 65 2d 72 75 6e 2d 70 6b 74 73 20 6d 74 rate-run-pkts mt
11830 63 6f 6e 66 20 74 6f 70 70 61 74 68 29 0a 09 09 conf toppath)...
11840 09 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 64 2d 70 . (common:load-p
11850 6b 74 73 2d 74 6f 2d 64 62 20 6d 74 63 6f 6e 66 kts-to-db mtconf
11860 29 0a 09 09 09 20 28 64 69 73 70 61 74 63 68 2d ).... (dispatch-
11870 63 6f 6d 6d 61 6e 64 73 20 6d 74 63 6f 6e 66 20 commands mtconf
11880 74 6f 70 70 61 74 68 29 29 29 0a 09 20 20 20 28 toppath))).. (
11890 28 69 6d 70 6f 72 74 29 20 20 20 28 63 6f 6d 6d (import) (comm
118a0 6f 6e 3a 6c 6f 61 64 2d 70 6b 74 73 2d 74 6f 2d on:load-pkts-to-
118b0 64 62 20 6d 74 63 6f 6e 66 29 29 20 3b 3b 20 69 db mtconf)) ;; i
118c0 6d 70 6f 72 74 20 70 6b 74 73 0a 09 20 20 20 28 mport pkts.. (
118d0 28 72 75 6e 67 65 6e 29 20 20 20 28 67 65 6e 65 (rungen) (gene
118e0 72 61 74 65 2d 72 75 6e 2d 70 6b 74 73 20 6d 74 rate-run-pkts mt
118f0 63 6f 6e 66 20 74 6f 70 70 61 74 68 29 29 0a 09 conf toppath))..
11900 20 20 20 28 28 64 69 73 70 61 74 63 68 29 20 28 ((dispatch) (
11910 64 69 73 70 61 74 63 68 2d 63 6f 6d 6d 61 6e 64 dispatch-command
11920 73 20 6d 74 63 6f 6e 66 20 74 6f 70 70 61 74 68 s mtconf toppath
11930 29 29 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 6d ))))). ;; m
11940 69 73 63 0a 20 20 20 20 20 20 28 28 73 68 6f 77 isc. ((show
11950 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 ). (if (>
11960 28 6c 65 6e 67 74 68 20 72 65 6d 61 72 67 73 29 (length remargs)
11970 20 30 29 0a 09 20 20 20 28 6c 65 74 2a 20 28 28 0).. (let* ((
11980 6d 74 63 6f 6e 66 64 61 74 20 28 73 69 6d 70 6c mtconfdat (simpl
11990 65 2d 73 65 74 75 70 20 28 61 72 67 73 3a 67 65 e-setup (args:ge
119a0 74 2d 61 72 67 20 22 2d 73 74 61 72 74 2d 64 69 t-arg "-start-di
119b0 72 22 29 29 29 0a 09 09 20 20 28 6d 74 63 6f 6e r")))... (mtcon
119c0 66 20 20 20 20 28 63 61 72 20 6d 74 63 6f 6e 66 f (car mtconf
119d0 64 61 74 29 29 0a 09 09 20 20 28 73 65 63 74 2d dat))... (sect-
119e0 64 61 74 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 dat (configf:get
119f0 2d 73 65 63 74 69 6f 6e 20 6d 74 63 6f 6e 66 20 -section mtconf
11a00 28 63 61 72 20 72 65 6d 61 72 67 73 29 29 29 29 (car remargs))))
11a10 0a 09 20 20 20 20 20 28 69 66 20 73 65 63 74 2d .. (if sect-
11a20 64 61 74 0a 09 09 20 28 66 6f 72 2d 65 61 63 68 dat... (for-each
11a30 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 65 6e ... (lambda (en
11a40 74 72 79 29 0a 09 09 20 20 20 20 28 69 66 20 28 try)... (if (
11a50 3e 20 28 6c 65 6e 67 74 68 20 65 6e 74 72 79 29 > (length entry)
11a60 20 31 29 0a 09 09 09 28 70 72 69 6e 74 20 28 63 1)....(print (c
11a70 61 72 20 65 6e 74 72 79 29 20 22 20 20 20 22 20 ar entry) " "
11a80 28 63 61 64 72 20 65 6e 74 72 79 29 29 0a 09 09 (cadr entry))...
11a90 09 28 70 72 69 6e 74 20 28 63 61 72 20 65 6e 74 .(print (car ent
11aa0 72 79 29 29 29 29 0a 09 09 20 20 73 65 63 74 2d ry))))... sect-
11ab0 64 61 74 29 0a 09 09 20 28 70 72 69 6e 74 20 22 dat)... (print "
11ac0 4e 6f 20 73 65 63 74 69 6f 6e 20 5c 22 22 20 28 No section \"" (
11ad0 63 61 72 20 72 65 6d 61 72 67 73 29 20 22 5c 22 car remargs) "\"
11ae0 20 66 6f 75 6e 64 22 29 29 29 0a 09 20 20 20 28 found"))).. (
11af0 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 6c 69 print "ERROR: li
11b00 73 74 20 72 65 71 75 69 72 65 73 20 73 65 63 74 st requires sect
11b10 69 6f 6e 20 70 61 72 61 6d 65 74 65 72 3b 20 61 ion parameter; a
11b20 72 65 61 73 2c 20 73 65 74 75 70 20 6f 72 20 63 reas, setup or c
11b30 6f 6e 74 6f 75 72 73 22 29 29 29 0a 20 20 20 20 ontours"))).
11b40 20 20 28 28 67 65 6e 64 6f 74 29 0a 20 20 20 20 ((gendot).
11b50 20 20 20 28 6c 65 74 2a 20 28 28 6d 74 63 6f 6e (let* ((mtcon
11b60 66 64 61 74 20 28 73 69 6d 70 6c 65 2d 73 65 74 fdat (simple-set
11b70 75 70 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 up (args:get-arg
11b80 20 22 2d 73 74 61 72 74 2d 64 69 72 22 29 29 29 "-start-dir")))
11b90 0a 09 20 20 20 20 20 20 28 6d 74 63 6f 6e 66 20 .. (mtconf
11ba0 20 20 20 28 63 61 72 20 6d 74 63 6f 6e 66 64 61 (car mtconfda
11bb0 74 29 29 29 0a 09 20 28 63 6f 6d 6d 6f 6e 3a 6c t))).. (common:l
11bc0 6f 61 64 2d 70 6b 74 73 2d 74 6f 2d 64 62 20 6d oad-pkts-to-db m
11bd0 74 63 6f 6e 66 20 75 73 65 2d 6c 74 3a 20 23 74 tconf use-lt: #t
11be0 29 20 3b 3b 20 6e 65 65 64 20 74 6f 20 4e 4f 54 ) ;; need to NOT
11bf0 20 64 6f 20 74 68 69 73 20 62 79 20 64 65 66 61 do this by defa
11c00 75 6c 74 20 2e 2e 2e 0a 09 20 28 63 6f 6d 6d 6f ult ..... (commo
11c10 6e 3a 77 69 74 68 2d 71 75 65 75 65 2d 64 62 0a n:with-queue-db.
11c20 09 20 20 6d 74 63 6f 6e 66 0a 09 20 20 28 6c 61 . mtconf.. (la
11c30 6d 62 64 61 20 28 70 6b 74 73 64 69 72 73 20 70 mbda (pktsdirs p
11c40 6b 74 73 64 69 72 20 63 6f 6e 6e 29 0a 09 20 20 ktsdir conn)..
11c50 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
11c60 20 20 20 20 20 20 20 20 20 20 20 70 6b 74 73 70 pktsp
11c70 65 63 20 64 69 73 70 6c 61 79 2d 66 69 65 6c 64 ec display-field
11c80 73 20 0a 09 20 20 20 20 28 6d 61 6b 65 2d 72 65 s .. (make-re
11c90 70 6f 72 74 20 22 6f 75 74 2e 64 6f 74 22 20 63 port "out.dot" c
11ca0 6f 6e 6e 0a 09 09 09 20 27 28 28 63 6d 64 20 20 onn.... '((cmd
11cb0 20 20 20 20 2e 20 28 28 70 61 72 65 6e 74 20 2e . ((parent .
11cc0 20 50 29 0a 09 09 09 09 09 28 75 73 65 72 20 20 P)......(user
11cd0 20 2e 20 4d 29 0a 09 09 09 09 09 28 74 61 72 67 . M)......(targ
11ce0 65 74 20 2e 20 74 29 29 29 0a 09 09 09 20 20 20 et . t)))....
11cf0 28 72 75 6e 73 74 61 72 74 20 2e 20 28 28 70 61 (runstart . ((pa
11d00 72 65 6e 74 20 2e 20 50 29 0a 09 09 09 09 09 28 rent . P)......(
11d10 74 61 72 67 65 74 20 2e 20 74 29 29 29 0a 09 09 target . t)))...
11d20 09 20 20 20 28 72 75 6e 74 79 70 65 20 2e 20 28 . (runtype . (
11d30 28 70 61 72 65 6e 74 20 2e 20 50 29 29 29 29 20 (parent . P))))
11d40 3b 3b 20 70 6b 74 73 70 65 63 0a 09 09 09 20 27 ;; pktspec.... '
11d50 28 50 20 55 20 74 29 20 20 20 20 20 20 20 20 20 (P U t)
11d60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11d70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11d80 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 0a ;; .
11d90 09 09 09 20 29 29 29 29 29 20 20 3b 3b 20 6e 6f ... ))))) ;; no
11da0 20 70 74 79 70 65 73 20 6c 69 73 74 65 64 20 28 ptypes listed (
11db0 70 74 79 70 65 73 20 61 72 65 20 73 74 72 69 6e ptypes are strin
11dc0 67 73 20 6f 66 20 70 6b 74 20 74 79 70 65 73 20 gs of pkt types
11dd0 74 6f 20 72 65 61 64 20 66 72 6f 6d 20 64 62 0a to read from db.
11de0 20 20 20 20 20 20 28 28 64 62 29 0a 20 20 20 20 ((db).
11df0 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 (if (null? re
11e00 6d 61 72 67 73 29 0a 09 20 20 20 28 70 72 69 6e margs).. (prin
11e10 74 20 22 45 52 52 4f 52 3a 20 6d 69 73 73 69 6e t "ERROR: missin
11e20 67 20 73 75 62 20 63 6f 6d 6d 61 6e 64 20 66 6f g sub command fo
11e30 72 20 64 62 20 63 6f 6d 6d 61 6e 64 22 29 0a 09 r db command")..
11e40 20 20 20 28 6c 65 74 20 28 28 73 75 62 63 6d 64 (let ((subcmd
11e50 20 28 63 61 72 20 72 65 6d 61 72 67 73 29 29 29 (car remargs)))
11e60 0a 09 20 20 20 20 20 28 63 61 73 65 20 28 73 74 .. (case (st
11e70 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 75 62 ring->symbol sub
11e80 63 6d 64 29 0a 09 20 20 20 20 20 20 20 28 28 70 cmd).. ((p
11e90 67 73 63 68 65 6d 61 29 0a 09 09 28 6c 65 74 2a gschema)...(let*
11ea0 20 28 28 69 6e 73 74 61 6c 6c 2d 68 6f 6d 65 20 ((install-home
11eb0 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 (common:get-inst
11ec0 61 6c 6c 2d 61 72 65 61 29 29 0a 09 09 20 20 20 all-area))...
11ed0 20 20 20 20 28 73 63 68 65 6d 61 2d 66 69 6c 65 (schema-file
11ee0 20 20 28 63 6f 6e 63 20 69 6e 73 74 61 6c 6c 2d (conc install-
11ef0 68 6f 6d 65 20 22 2f 73 68 61 72 65 2f 64 62 2f home "/share/db/
11f00 6d 74 2d 70 67 2e 73 71 6c 22 29 29 29 0a 09 09 mt-pg.sql")))...
11f10 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (if (common:fi
11f20 6c 65 2d 65 78 69 73 74 73 3f 20 73 63 68 65 6d le-exists? schem
11f30 61 2d 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 a-file)...
11f40 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f (system (conc "/
11f50 62 69 6e 2f 63 61 74 20 22 20 73 63 68 65 6d 61 bin/cat " schema
11f60 2d 66 69 6c 65 29 29 29 29 29 0a 09 20 20 20 20 -file)))))..
11f70 20 20 20 28 28 73 71 6c 69 74 65 33 73 63 68 65 ((sqlite3sche
11f80 6d 61 29 0a 09 09 28 6c 65 74 2a 20 28 28 69 6e ma)...(let* ((in
11f90 73 74 61 6c 6c 2d 68 6f 6d 65 20 28 63 6f 6d 6d stall-home (comm
11fa0 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c 6c 2d 61 on:get-install-a
11fb0 72 65 61 29 29 0a 09 09 20 20 20 20 20 20 20 28 rea))... (
11fc0 73 63 68 65 6d 61 2d 66 69 6c 65 20 20 28 63 6f schema-file (co
11fd0 6e 63 20 69 6e 73 74 61 6c 6c 2d 68 6f 6d 65 20 nc install-home
11fe0 22 2f 73 68 61 72 65 2f 64 62 2f 6d 74 2d 73 71 "/share/db/mt-sq
11ff0 6c 69 74 65 33 2e 73 71 6c 22 29 29 29 0a 09 09 lite3.sql")))...
12000 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (if (common:fi
12010 6c 65 2d 65 78 69 73 74 73 3f 20 73 63 68 65 6d le-exists? schem
12020 61 2d 66 69 6c 65 29 0a 09 09 20 20 20 20 20 20 a-file)...
12030 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 2f (system (conc "/
12040 62 69 6e 2f 63 61 74 20 22 20 73 63 68 65 6d 61 bin/cat " schema
12050 2d 66 69 6c 65 29 29 29 29 29 0a 09 20 20 20 20 -file)))))..
12060 20 20 20 28 28 6a 75 6e 6b 29 0a 09 09 28 72 6d ((junk)...(rm
12070 74 3a 67 65 74 2d 6b 65 79 73 29 29 29 29 29 29 t:get-keys))))))
12080 0a 20 20 20 20 28 28 74 73 65 6e 64 29 0a 20 20 . ((tsend).
12090 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
120a0 72 65 6d 61 72 67 73 29 0a 09 20 20 20 20 20 20 remargs)..
120b0 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 6d (print "ERROR: m
120c0 69 73 73 69 6e 67 20 64 61 74 61 20 74 6f 20 73 issing data to s
120d0 65 6e 64 20 74 6f 20 74 72 69 67 67 65 72 20 6c end to trigger l
120e0 69 73 74 65 6e 65 72 73 22 29 0a 09 20 20 20 20 isteners")..
120f0 20 20 28 6c 65 74 2a 20 28 28 6d 73 67 20 20 20 (let* ((msg
12100 20 20 20 20 28 63 61 72 20 72 65 6d 61 72 67 73 (car remargs
12110 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
12120 20 20 20 20 20 28 6d 74 63 6f 6e 66 64 61 74 20 (mtconfdat
12130 28 73 69 6d 70 6c 65 2d 73 65 74 75 70 20 28 61 (simple-setup (a
12140 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 rgs:get-arg "-st
12150 61 72 74 2d 64 69 72 22 29 29 29 0a 20 20 20 20 art-dir"))).
12160 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
12170 74 63 6f 6e 66 20 20 20 20 28 63 61 72 20 6d 74 tconf (car mt
12180 63 6f 6e 66 64 61 74 29 29 0a 20 20 20 20 20 20 confdat)).
12190 20 20 20 20 20 20 20 20 20 20 20 20 28 74 69 6d (tim
121a0 65 2d 6f 75 74 20 20 28 69 66 20 28 61 72 67 73 e-out (if (args
121b0 3a 67 65 74 2d 61 72 67 20 22 2d 74 69 6d 65 2d :get-arg "-time-
121c0 6f 75 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 out").
121d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
121e0 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e (string->
121f0 6e 75 6d 62 65 72 20 28 61 72 67 73 3a 67 65 74 number (args:get
12200 2d 61 72 67 20 22 2d 74 69 6d 65 2d 6f 75 74 22 -arg "-time-out"
12210 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 )) .
12220 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12230 20 20 20 35 29 29 0a 20 20 20 20 20 20 20 20 20 5)).
12240 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 65 6e (listen
12250 65 72 73 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 ers (configf:get
12260 2d 73 65 63 74 69 6f 6e 20 6d 74 63 6f 6e 66 20 -section mtconf
12270 22 6c 69 73 74 65 6e 65 72 73 22 29 29 0a 20 20 "listeners")).
12280 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12290 28 75 73 65 72 2d 69 6e 66 6f 20 20 28 75 73 65 (user-info (use
122a0 72 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 28 63 r-information (c
122b0 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 29 urrent-user-id))
122c0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
122d0 20 20 20 20 28 70 72 65 76 2d 73 65 65 6e 20 28 (prev-seen (
122e0 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
122f0 29 29 20 3b 3b 20 63 61 74 63 68 20 64 75 70 6c )) ;; catch dupl
12300 69 63 61 74 65 73 0a 20 20 20 20 20 20 20 20 20 icates.
12310 20 20 20 20 28 69 66 20 75 73 65 72 2d 69 6e 66 (if user-inf
12320 6f 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 o.
12330 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
12340 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a (for-each.
12350 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
12360 61 6d 62 64 61 20 28 6c 69 73 74 65 6e 65 72 29 ambda (listener)
12370 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
12380 20 28 6c 65 74 20 28 28 68 6f 73 74 2d 70 6f 72 (let ((host-por
12390 74 20 28 63 61 72 20 6c 69 73 74 65 6e 65 72 29 t (car listener)
123a0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
123b0 20 20 20 20 20 20 20 20 28 61 74 74 72 69 62 20 (attrib
123c0 28 76 61 6c 2d 3e 61 6c 69 73 74 20 28 63 61 64 (val->alist (cad
123d0 72 20 6c 69 73 74 65 6e 65 72 29 29 29 29 0a 20 r listener)))).
123e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
123f0 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c (if (and (equal
12400 3f 20 6d 73 67 20 22 74 69 6d 65 2d 74 6f 2d 64 ? msg "time-to-d
12410 69 65 22 29 20 28 6e 6f 74 20 28 63 61 6e 2d 75 ie") (not (can-u
12420 73 65 72 2d 6b 69 6c 6c 2d 6c 69 73 74 6e 65 72 ser-kill-listner
12430 20 75 73 65 72 2d 69 6e 66 6f 20 61 74 74 72 69 user-info attri
12440 62 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 b))).
12450 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
12460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12470 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
12480 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
12490 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 73 lt-log-port* "Us
124a0 65 72 20 22 20 28 63 61 72 20 75 73 65 72 2d 69 er " (car user-i
124b0 6e 66 6f 29 20 22 20 69 73 20 6e 6f 74 20 61 6c nfo) " is not al
124c0 6c 6f 77 65 64 20 74 6f 20 73 65 6e 64 20 6d 65 lowed to send me
124d0 73 73 61 67 65 20 27 22 20 6d 73 67 22 27 22 29 ssage '" msg"'")
124e0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
124f0 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
12500 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
12510 20 20 20 20 28 70 72 69 6e 74 20 22 73 65 6e 64 (print "send
12520 69 6e 67 20 22 20 6d 73 67 20 22 20 74 6f 20 22 ing " msg " to "
12530 20 68 6f 73 74 2d 70 6f 72 74 20 29 0a 20 20 20 host-port ).
12540 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
12550 6f 70 65 6e 2d 73 65 6e 64 2d 63 6c 6f 73 65 2d open-send-close-
12560 6e 6e 20 68 6f 73 74 2d 70 6f 72 74 20 6d 73 67 nn host-port msg
12570 20 61 74 74 72 69 62 20 74 69 6d 65 6f 75 74 3a attrib timeout:
12580 20 74 69 6d 65 2d 6f 75 74 20 29 29 29 0a 20 20 time-out ))).
12590 20 20 20 20 20 20 20 20 20 20 20 20 6c 69 73 74 list
125a0 65 6e 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 eners)).
125b0 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
125c0 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
125d0 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
125e0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
125f0 72 74 2a 20 22 43 6f 75 6c 64 20 6e 6f 74 20 49 rt* "Could not I
12600 64 65 6e 74 69 66 79 20 65 78 65 63 75 74 69 6e dentify executin
12610 67 20 75 73 65 72 2e 20 57 69 6c 6c 20 6e 6f 74 g user. Will not
12620 20 73 65 6e 64 20 61 6e 79 20 6d 65 73 73 61 67 send any messag
12630 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e").
12640 20 20 20 28 65 78 69 74 20 31 29 29 29 29 29 29 (exit 1))))))
12650 0a 20 20 20 20 20 28 28 74 71 75 65 72 79 29 0a . ((tquery).
12660 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
12670 3f 20 72 65 6d 61 72 67 73 29 0a 09 20 20 20 20 ? remargs)..
12680 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
12690 20 6d 69 73 73 69 6e 67 20 64 61 74 61 20 74 6f missing data to
126a0 20 73 65 6e 64 20 74 6f 20 74 72 69 67 67 65 72 send to trigger
126b0 20 6c 69 73 74 65 6e 65 72 73 22 29 0a 09 20 20 listeners")..
126c0 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 73 67 20 (let* ((msg
126d0 20 20 20 20 20 20 28 63 61 72 20 72 65 6d 61 72 (car remar
126e0 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 gs)).
126f0 20 20 20 20 20 20 20 28 6d 74 63 6f 6e 66 64 61 (mtconfda
12700 74 20 28 73 69 6d 70 6c 65 2d 73 65 74 75 70 20 t (simple-setup
12710 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
12720 73 74 61 72 74 2d 64 69 72 22 29 29 29 0a 20 20 start-dir"))).
12730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12740 28 6d 74 63 6f 6e 66 20 20 20 20 28 63 61 72 20 (mtconf (car
12750 6d 74 63 6f 6e 66 64 61 74 29 29 0a 20 20 20 20 mtconfdat)).
12760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
12770 69 6d 65 2d 6f 75 74 20 20 28 69 66 20 28 61 72 ime-out (if (ar
12780 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 69 6d gs:get-arg "-tim
12790 65 2d 6f 75 74 22 29 0a 20 20 20 20 20 20 20 20 e-out").
127a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
127b0 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
127c0 2d 3e 6e 75 6d 62 65 72 20 28 61 72 67 73 3a 67 ->number (args:g
127d0 65 74 2d 61 72 67 20 22 2d 74 69 6d 65 2d 6f 75 et-arg "-time-ou
127e0 74 22 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 t")) .
127f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12800 20 20 20 20 20 35 29 29 0a 20 20 20 20 20 20 20 5)).
12810 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
12820 65 6e 65 72 73 20 28 63 6f 6e 66 69 67 66 3a 67 eners (configf:g
12830 65 74 2d 73 65 63 74 69 6f 6e 20 6d 74 63 6f 6e et-section mtcon
12840 66 20 22 6c 69 73 74 65 6e 65 72 73 22 29 29 0a f "listeners")).
12850 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12860 20 20 28 75 73 65 72 2d 69 6e 66 6f 20 20 28 75 (user-info (u
12870 73 65 72 2d 69 6e 66 6f 72 6d 61 74 69 6f 6e 20 ser-information
12880 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
12890 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
128a0 20 20 20 20 20 20 28 70 72 65 76 2d 73 65 65 6e (prev-seen
128b0 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
128c0 65 29 29 29 20 3b 3b 20 63 61 74 63 68 20 64 75 e))) ;; catch du
128d0 70 6c 69 63 61 74 65 73 0a 20 20 20 20 20 20 20 plicates.
128e0 20 20 20 20 20 20 28 69 66 20 75 73 65 72 2d 69 (if user-i
128f0 6e 66 6f 0a 20 20 20 20 20 20 20 20 20 20 20 20 nfo.
12900 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
12910 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 (for-eac
12920 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 h.
12930 28 6c 61 6d 62 64 61 20 28 6c 69 73 74 65 6e 65 (lambda (listene
12940 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 r).
12950 20 20 20 28 6c 65 74 20 28 28 68 6f 73 74 2d 70 (let ((host-p
12960 6f 72 74 20 28 63 61 72 20 6c 69 73 74 65 6e 65 ort (car listene
12970 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 r)).
12980 20 20 20 20 20 20 20 20 20 20 28 61 74 74 72 69 (attri
12990 62 20 28 76 61 6c 2d 3e 61 6c 69 73 74 20 28 63 b (val->alist (c
129a0 61 64 72 20 6c 69 73 74 65 6e 65 72 29 29 29 29 adr listener))))
129b0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
129c0 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 (if (and (equ
129d0 61 6c 3f 20 6d 73 67 20 22 74 69 6d 65 2d 74 6f al? msg "time-to
129e0 2d 64 69 65 22 29 20 28 6e 6f 74 20 28 63 61 6e -die") (not (can
129f0 2d 75 73 65 72 2d 6b 69 6c 6c 2d 6c 69 73 74 6e -user-kill-listn
12a00 65 72 20 75 73 65 72 2d 69 6e 66 6f 20 61 74 74 er user-info att
12a10 72 69 62 29 29 29 0a 20 20 20 20 20 20 20 20 20 rib))).
12a20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
12a30 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
12a40 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
12a50 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
12a60 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
12a70 55 73 65 72 20 22 20 28 63 61 72 20 75 73 65 72 User " (car user
12a80 2d 69 6e 66 6f 29 20 22 20 69 73 20 6e 6f 74 20 -info) " is not
12a90 61 6c 6c 6f 77 65 64 20 74 6f 20 73 65 6e 64 20 allowed to send
12aa0 6d 65 73 73 61 67 65 20 27 22 20 6d 73 67 22 27 message '" msg"'
12ab0 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
12ac0 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 (exit 1
12ad0 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
12ae0 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 73 65 (print "se
12af0 6e 64 69 6e 67 20 22 20 6d 73 67 20 22 20 74 6f nding " msg " to
12b00 20 22 20 68 6f 73 74 2d 70 6f 72 74 20 29 0a 20 " host-port ).
12b10 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12b20 20 28 6f 70 65 6e 2d 73 65 6e 64 2d 72 65 63 65 (open-send-rece
12b30 69 76 65 2d 6e 6e 20 68 6f 73 74 2d 70 6f 72 74 ive-nn host-port
12b40 20 6d 73 67 20 61 74 74 72 69 62 20 74 69 6d 65 msg attrib time
12b50 6f 75 74 3a 20 74 69 6d 65 2d 6f 75 74 20 29 29 out: time-out ))
12b60 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
12b70 6c 69 73 74 65 6e 65 72 73 29 29 0a 20 20 20 20 listeners)).
12b80 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
12b90 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
12ba0 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
12bb0 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
12bc0 67 2d 70 6f 72 74 2a 20 22 43 6f 75 6c 64 20 6e g-port* "Could n
12bd0 6f 74 20 49 64 65 6e 74 69 66 79 20 65 78 65 63 ot Identify exec
12be0 75 74 69 6e 67 20 75 73 65 72 2e 20 57 69 6c 6c uting user. Will
12bf0 20 6e 6f 74 20 73 65 6e 64 20 61 6e 79 20 6d 65 not send any me
12c00 73 73 61 67 65 22 29 0a 20 20 20 20 20 20 20 20 ssage").
12c10 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
12c20 29 29 29 29 0a 0a 20 20 20 20 28 28 74 71 75 65 )))).. ((tque
12c30 72 79 6c 69 73 74 65 6e 29 0a 20 20 20 20 20 20 rylisten).
12c40 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 61 (if (null? rema
12c50 72 67 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 rgs).
12c60 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 75 (print "ERROR: u
12c70 73 65 61 67 65 20 66 6f 72 20 74 6c 69 73 74 65 seage for tliste
12c80 6e 20 69 73 20 5c 22 6d 74 75 74 69 6c 20 74 6c n is \"mtutil tl
12c90 69 73 74 65 6e 20 70 6f 72 74 6e 75 6d 5c 22 22 isten portnum\""
12ca0 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 ). (le
12cb0 74 20 28 28 70 6f 72 74 6e 75 6d 20 28 73 74 72 t ((portnum (str
12cc0 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 72 ing->number (car
12cd0 20 72 65 6d 61 72 67 73 29 29 29 29 0a 20 20 20 remargs)))).
12ce0 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 .
12cf0 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
12d00 74 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 t portnum).
12d10 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 (pri
12d20 6e 74 20 22 45 52 52 4f 52 3a 20 74 68 65 20 70 nt "ERROR: the p
12d30 6f 72 74 6e 75 6d 62 65 72 20 70 61 72 61 6d 65 ortnumber parame
12d40 74 65 72 20 6d 75 73 74 20 62 65 20 61 20 6e 75 ter must be a nu
12d50 6d 62 65 72 2c 20 79 6f 75 20 67 61 76 65 3a 20 mber, you gave:
12d60 22 20 28 63 61 72 20 72 65 6d 61 72 67 73 29 29 " (car remargs))
12d70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
12d80 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
12d90 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
12da0 28 6e 6f 74 20 28 69 73 2d 70 6f 72 74 2d 69 6e (not (is-port-in
12db0 2d 75 73 65 20 70 6f 72 74 6e 75 6d 29 29 20 20 -use portnum))
12dc0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
12dd0 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
12de0 72 65 70 20 20 20 20 20 20 20 28 73 74 61 72 74 rep (start
12df0 2d 6e 6e 2d 73 65 72 76 65 72 20 70 6f 72 74 6e -nn-server portn
12e00 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 um)).
12e10 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12e20 20 20 20 28 6d 74 63 6f 6e 66 64 61 74 20 28 73 (mtconfdat (s
12e30 69 6d 70 6c 65 2d 73 65 74 75 70 20 28 61 72 67 imple-setup (arg
12e40 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 61 72 s:get-arg "-star
12e50 74 2d 64 69 72 22 29 29 29 0a 20 20 20 20 20 20 t-dir"))).
12e60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12e70 20 20 20 20 20 20 20 20 28 6d 74 63 6f 6e 66 20 (mtconf
12e80 20 20 20 28 63 61 72 20 6d 74 63 6f 6e 66 64 61 (car mtconfda
12e90 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
12ea0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12eb0 20 20 28 63 6f 6e 74 61 63 74 20 20 20 28 63 6f (contact (co
12ec0 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 6d 74 63 nfigf:lookup mtc
12ed0 6f 6e 66 20 22 6c 69 73 74 65 6e 65 72 22 20 22 onf "listener" "
12ee0 6f 77 6e 65 72 22 29 29 0a 20 20 20 20 20 20 20 owner")).
12ef0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12f00 20 20 20 20 20 20 20 28 73 63 72 69 70 74 20 20 (script
12f10 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
12f20 70 20 6d 74 63 6f 6e 66 20 22 6c 69 73 74 65 6e p mtconf "listen
12f30 65 72 22 20 22 73 63 72 69 70 74 22 29 29 29 0a er" "script"))).
12f40 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12f50 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 (print
12f60 22 4c 69 73 74 65 6e 69 6e 67 20 6f 6e 20 70 6f "Listening on po
12f70 72 74 20 22 20 70 6f 72 74 6e 75 6d 20 22 20 66 rt " portnum " f
12f80 6f 72 20 6d 65 73 73 61 67 65 73 2e 22 29 0a 20 or messages.").
12f90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12fa0 20 20 20 20 20 20 20 20 28 73 65 74 2d 73 69 67 (set-sig
12fb0 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
12fc0 6e 61 6c 2f 69 6e 74 20 20 28 6c 61 6d 62 64 61 nal/int (lambda
12fd0 20 28 73 69 67 6e 75 6d 29 20 0a 09 09 09 09 09 (signum) ......
12fe0 09 09 09 09 09 09 09 09 09 09 28 73 65 74 21 20 ..........(set!
12ff0 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 *time-to-exit* #
13000 74 29 0a 20 20 09 09 09 09 09 09 09 09 09 09 09 t). ...........
13010 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
13020 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
13030 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 -log-port* "Rece
13040 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 69 ived signal " si
13050 67 6e 75 6d 20 22 20 73 65 6e 64 69 6e 67 20 65 gnum " sending e
13060 6d 61 69 6c 20 62 65 66 6f 72 20 65 78 69 74 69 mail befor exiti
13070 6e 67 20 21 21 22 29 0a 20 20 09 09 09 09 09 09 ng !!"). ......
13080 09 09 09 09 09 09 09 09 28 6c 65 74 20 28 28 65 ........(let ((e
13090 6d 61 69 6c 2d 62 6f 64 79 20 28 6d 74 75 74 3a mail-body (mtut:
130a0 73 74 6d 6c 2d 3e 73 74 72 69 6e 67 20 28 73 3a stml->string (s:
130b0 62 6f 64 79 0a 09 09 09 09 09 09 09 09 09 09 09 body............
130c0 09 09 09 09 09 09 09 09 09 09 09 28 73 3a 70 20 ...........(s:p
130d0 28 63 6f 6e 63 20 22 52 65 63 65 69 76 65 64 20 (conc "Received
130e0 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 signal " signum
130f0 22 2e 20 4c 69 73 74 65 72 20 68 61 73 20 62 65 ". Lister has be
13100 65 6e 20 74 65 72 6d 69 6e 61 74 65 64 20 6f 6e en terminated on
13110 20 68 6f 73 74 20 22 20 28 67 65 74 2d 65 6e 76 host " (get-env
13120 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
13130 65 20 22 48 4f 53 54 22 29 20 22 2e 20 22 29 29 e "HOST") ". "))
13140 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
13150 20 20 09 09 09 09 09 20 20 20 20 20 20 20 20 28 ..... (
13160 73 65 6e 64 6d 61 69 6c 20 63 6f 6e 74 61 63 74 sendmail contact
13170 20 22 4c 69 73 74 6e 65 72 20 68 61 73 20 62 65 "Listner has be
13180 65 6e 20 74 65 72 6d 69 6e 61 74 65 64 2e 22 20 en terminated."
13190 65 6d 61 69 6c 2d 62 6f 64 79 20 20 75 73 65 5f email-body use_
131a0 68 74 6d 6c 3a 20 23 74 29 29 0a 20 20 20 20 20 html: #t)).
131b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
131c0 20 20 20 20 20 20 20 20 20 28 65 78 69 74 29 29 (exit))
131d0 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 )...............
131e0 09 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e .(set-signal-han
131f0 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 dler! signal/ter
13200 6d 20 20 28 6c 61 6d 62 64 61 20 28 73 69 67 6e m (lambda (sign
13210 75 6d 29 20 0a 09 09 09 09 09 09 09 09 09 09 09 um) ............
13220 09 09 09 09 28 73 65 74 21 20 2a 74 69 6d 65 2d ....(set! *time-
13230 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 09 to-exit* #t). .
13240 09 09 09 09 09 09 09 09 09 09 09 09 09 28 64 65 .............(de
13250 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
13260 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
13270 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 73 ort* "Received s
13280 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
13290 20 73 65 6e 64 69 6e 67 20 65 6d 61 69 6c 20 62 sending email b
132a0 65 66 6f 72 20 65 78 69 74 69 6e 67 20 21 21 22 efor exiting !!"
132b0 29 0a 20 20 09 09 09 09 09 09 09 09 09 09 09 09 ). ............
132c0 09 09 28 6c 65 74 20 28 28 65 6d 61 69 6c 2d 62 ..(let ((email-b
132d0 6f 64 79 20 28 6d 74 75 74 3a 73 74 6d 6c 2d 3e ody (mtut:stml->
132e0 73 74 72 69 6e 67 20 28 73 3a 62 6f 64 79 0a 09 string (s:body..
132f0 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
13300 09 09 09 09 09 28 73 3a 70 20 28 63 6f 6e 63 20 .....(s:p (conc
13310 22 52 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c "Received signal
13320 20 22 20 73 69 67 6e 75 6d 20 22 2e 20 4c 69 73 " signum ". Lis
13330 74 65 72 20 68 61 73 20 62 65 65 6e 20 74 65 72 ter has been ter
13340 6d 69 6e 61 74 65 64 20 6f 6e 20 68 6f 73 74 20 minated on host
13350 22 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 " (get-environme
13360 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 53 nt-variable "HOS
13370 54 22 29 20 22 2e 20 22 29 29 29 29 29 29 0a 20 T") ". ")))))).
13380 20 20 20 20 20 20 20 20 20 20 20 20 09 09 09 09 ....
13390 09 20 20 20 20 20 20 20 20 28 73 65 6e 64 6d 61 . (sendma
133a0 69 6c 20 63 6f 6e 74 61 63 74 20 22 4c 69 73 74 il contact "List
133b0 6e 65 72 20 68 61 73 20 62 65 65 6e 20 74 65 72 ner has been ter
133c0 6d 69 6e 61 74 65 64 2e 22 20 65 6d 61 69 6c 2d minated." email-
133d0 62 6f 64 79 20 20 75 73 65 5f 68 74 6d 6c 3a 20 body use_html:
133e0 23 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 #t)).
133f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13400 20 20 20 28 65 78 69 74 29 29 29 0a 0a 20 20 20 (exit)))..
13410 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13420 20 20 20 20 20 20 3b 28 73 65 74 2d 73 69 67 6e ;(set-sign
13430 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
13440 61 6c 2f 74 65 72 6d 20 73 70 65 63 69 61 6c 2d al/term special-
13450 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 0a signal-handler).
13460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13470 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
13480 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13490 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 (let loop ((i
134a0 6e 73 74 72 20 28 6e 6e 2d 72 65 63 76 20 72 65 nstr (nn-recv re
134b0 70 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 p))).
134c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
134d0 20 20 3b 3b 28 6e 6e 2d 73 65 6e 64 20 72 65 70 ;;(nn-send rep
134e0 20 22 33 2e 39 22 29 0a 20 20 20 20 20 20 20 20 "3.9").
134f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13500 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
13510 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 -from-pipe (conc
13520 20 22 2f 75 73 72 2f 62 69 6e 2f 75 70 74 69 6d "/usr/bin/uptim
13530 65 20 7c 20 63 75 74 20 2d 64 27 3a 27 20 2d 66 e | cut -d':' -f
13540 34 20 7c 20 61 77 6b 20 27 7b 70 72 69 6e 74 20 4 | awk '{print
13550 24 31 7d 27 20 7c 20 63 75 74 20 2d 64 27 2c 27 $1}' | cut -d','
13560 20 2d 66 31 22 29 0a 20 20 20 20 20 20 20 20 20 -f1").
13570 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13580 20 20 20 20 09 28 6c 61 6d 62 64 61 28 29 0a 20 .(lambda().
13590 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
135a0 20 20 20 20 20 20 20 20 20 20 20 20 09 09 28 6c ..(l
135b0 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 et loop ((inl (r
135c0 65 61 64 2d 6c 69 6e 65 29 29 29 0a 20 20 20 20 ead-line))).
135d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
135e0 20 20 20 20 20 20 09 09 09 09 28 69 66 20 28 6e ....(if (n
135f0 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 ot (eof-object?
13600 69 6e 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 inl)).
13610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13620 20 20 20 20 09 09 09 09 28 62 65 67 69 6e 0a 20 ....(begin.
13630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13640 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 09 .
13650 09 09 3b 3b 28 70 72 69 6e 74 20 22 66 64 6b 37 ..;;(print "fdk7
13660 33 3a 20 22 20 69 6e 6c 20 22 3a 22 29 0a 20 20 3: " inl ":").
13670 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13680 20 20 20 20 20 20 20 20 20 20 20 20 20 20 09 09 ..
13690 09 3b 3b 28 73 65 74 21 20 63 75 72 72 65 6e 74 .;;(set! current
136a0 2d 6c 69 73 74 2d 63 69 61 66 20 28 61 70 70 65 -list-ciaf (appe
136b0 6e 64 21 20 63 75 72 72 65 6e 74 2d 6c 69 73 74 nd! current-list
136c0 2d 63 69 61 66 20 28 6c 69 73 74 20 28 73 74 72 -ciaf (list (str
136d0 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 ing-substitute "
136e0 5c 5c 73 2b 24 22 20 22 22 20 69 6e 6c 29 29 29 \\s+$" "" inl)))
136f0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
13700 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13710 20 20 09 09 09 28 6e 6e 2d 73 65 6e 64 20 72 65 ...(nn-send re
13720 70 20 69 6e 6c 29 0a 20 20 20 20 20 20 20 20 20 p inl).
13730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13740 20 20 20 20 20 20 20 09 09 09 28 6c 6f 6f 70 28 ...(loop(
13750 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 20 20 20 read-line))).
13760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13770 20 20 20 20 20 20 20 09 09 09 09 29 29 0a 0a 20 ....))..
13780 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13790 20 20 20 20 20 20 20 20 20 20 20 20 09 29 0a 20 .).
137a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
137b0 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 20 20 ).
137c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
137d0 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 70 72 ;;(pr
137e0 69 6e 74 20 28 69 73 79 73 20 22 2f 75 73 72 2f int (isys "/usr/
137f0 62 69 6e 2f 75 70 74 69 6d 65 22 20 66 6f 72 65 bin/uptime" fore
13800 61 63 68 2d 73 74 64 6f 75 74 2d 74 68 75 6e 6b ach-stdout-thunk
13810 3a 20 66 6f 72 65 61 63 68 2d 73 74 64 6f 75 74 : foreach-stdout
13820 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
13830 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13840 28 6c 65 74 20 28 28 63 74 69 6d 65 20 28 64 61 (let ((ctime (da
13850 74 65 2d 3e 73 74 72 69 6e 67 20 28 63 75 72 72 te->string (curr
13860 65 6e 74 2d 64 61 74 65 29 29 29 29 20 0a 20 20 ent-date)))) .
13870 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13880 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 20 (if
13890 28 65 71 75 61 6c 3f 20 69 6e 73 74 72 20 22 74 (equal? instr "t
138a0 69 6d 65 2d 74 6f 2d 64 69 65 22 29 0a 20 20 20 ime-to-die").
138b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
138c0 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
138d0 6e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n .
138e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
138f0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
13900 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
13910 74 2a 20 63 74 69 6d 65 20 22 20 72 65 63 65 69 t* ctime " recei
13920 76 65 64 20 27 22 20 69 6e 73 74 72 20 22 27 2e ved '" instr "'.
13930 20 54 69 6d 65 20 74 6f 20 73 75 63 69 64 65 2e Time to sucide.
13940 22 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 " ).
13950 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13960 20 20 20 28 6c 65 74 20 28 28 70 69 64 20 20 28 (let ((pid (
13970 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
13980 69 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 id))).
13990 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
139a0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
139b0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
139c0 70 6f 72 74 2a 20 22 4b 69 6c 6c 69 6e 67 20 63 port* "Killing c
139d0 75 72 72 65 6e 74 20 70 72 6f 63 65 73 73 20 28 urrent process (
139e0 70 69 64 3d 22 20 70 69 64 20 22 29 22 29 0a 20 pid=" pid ")").
139f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13a00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
13a10 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6b 69 6c ystem (conc "kil
13a20 6c 20 22 20 70 69 64 29 29 29 29 20 20 0a 20 20 l " pid)))) .
13a30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13a40 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
13a50 6e 0a 09 09 09 09 09 09 09 09 28 64 65 62 75 67 n.........(debug
13a60 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
13a70 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 63 74 69 6d t-log-port* ctim
13a80 65 20 22 20 72 65 63 65 69 76 65 64 20 22 20 69 e " received " i
13a90 6e 73 74 72 20 29 0a 09 09 09 09 09 09 09 09 3b nstr ).........;
13aa0 28 6e 6e 2d 73 65 6e 64 20 72 65 70 20 22 6f 6b (nn-send rep "ok
13ab0 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
13ac0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13ad0 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 (if (not (equ
13ae0 61 6c 3f 20 69 6e 73 74 72 20 22 70 69 6e 67 22 al? instr "ping"
13af0 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
13b00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13b10 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
13b20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13b30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
13b40 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
13b50 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
13b60 20 63 74 69 6d 65 20 22 20 72 75 6e 6e 69 6e 67 ctime " running
13b70 20 5c 22 22 20 73 63 72 69 70 74 20 22 20 22 20 \"" script " "
13b80 69 6e 73 74 72 20 22 5c 22 22 29 0a 20 20 20 20 instr "\"").
13b90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13ba0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13bb0 3b 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 ;(system (conc s
13bc0 63 72 69 70 74 20 22 20 27 22 20 69 6e 73 74 72 cript " '" instr
13bd0 20 22 27 22 29 29 0a 20 20 20 20 20 20 20 20 20 "'")).
13be0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13bf0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
13c00 6f 63 65 73 73 2d 72 75 6e 20 73 63 72 69 70 74 ocess-run script
13c10 20 28 6c 69 73 74 20 20 69 6e 73 74 72 20 29 29 (list instr ))
13c20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
13c30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13c40 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
13c50 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
13c60 6c 6f 67 2d 70 6f 72 74 2a 20 63 74 69 6d 65 20 log-port* ctime
13c70 22 20 64 6f 6e 65 22 20 29 29 0a 20 20 20 20 20 " done" )).
13c80 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13c90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
13ca0 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
13cb0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13cc0 20 20 20 20 20 20 20 20 09 20 28 69 66 20 28 6e . (if (n
13cd0 6f 74 20 28 65 71 75 61 6c 3f 20 69 6e 73 74 72 ot (equal? instr
13ce0 20 22 6c 6f 61 64 22 29 29 0a 20 20 20 20 20 20 "load")).
13cf0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13d00 20 20 20 20 20 20 20 20 20 20 20 20 20 09 20 09 . .
13d10 28 70 72 69 6e 74 20 22 43 68 65 63 6b 69 6e 67 (print "Checking
13d20 20 6c 6f 61 64 22 29 0a 0a 20 20 20 20 20 20 20 load")..
13d30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13d40 20 20 20 20 20 20 20 20 20 20 20 20 09 20 29 20 . )
13d50 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
13d60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13d70 20 20 20 20 29 0a 0a 20 20 20 20 20 20 20 20 20 )..
13d80 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13d90 20 20 20 20 20 20 20 20 20 29 0a 0a 20 20 20 20 )..
13da0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13db0 20 20 20 20 20 20 20 20 20 20 20 20 29 29 29 0a ))).
13dc0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13dd0 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 (loop
13de0 20 28 6e 6e 2d 72 65 63 76 20 72 65 70 29 29 29 (nn-recv rep)))
13df0 29 0a 09 09 20 20 20 20 20 20 20 28 70 72 69 6e )... (prin
13e00 74 20 22 45 52 52 4f 52 3a 20 50 6f 72 74 20 22 t "ERROR: Port "
13e10 20 70 6f 72 74 6e 75 6d 20 22 20 61 6c 72 65 61 portnum " alrea
13e20 64 79 20 69 6e 20 75 73 65 2e 20 54 72 79 20 61 dy in use. Try a
13e30 6e 6f 74 68 65 72 20 70 6f 72 74 22 29 29 29 29 nother port"))))
13e40 29 29 29 0a 20 20 20 20 20 20 0a 0a 0a 0a 20 20 ))). ....
13e50 20 20 20 20 28 28 74 6c 69 73 74 65 6e 29 0a 20 ((tlisten).
13e60 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
13e70 20 72 65 6d 61 72 67 73 29 0a 20 20 20 20 20 20 remargs).
13e80 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
13e90 4f 52 3a 20 75 73 65 61 67 65 20 66 6f 72 20 74 OR: useage for t
13ea0 6c 69 73 74 65 6e 20 69 73 20 5c 22 6d 74 75 74 listen is \"mtut
13eb0 69 6c 20 74 6c 69 73 74 65 6e 20 70 6f 72 74 6e il tlisten portn
13ec0 75 6d 5c 22 22 29 0a 20 20 20 20 20 20 20 20 20 um\"").
13ed0 20 20 28 6c 65 74 20 28 28 70 6f 72 74 6e 75 6d (let ((portnum
13ee0 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
13ef0 20 28 63 61 72 20 72 65 6d 61 72 67 73 29 29 29 (car remargs)))
13f00 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
13f10 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 . (i
13f20 66 20 28 6e 6f 74 20 70 6f 72 74 6e 75 6d 29 0a f (not portnum).
13f30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13f40 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
13f50 74 68 65 20 70 6f 72 74 6e 75 6d 62 65 72 20 70 the portnumber p
13f60 61 72 61 6d 65 74 65 72 20 6d 75 73 74 20 62 65 arameter must be
13f70 20 61 20 6e 75 6d 62 65 72 2c 20 79 6f 75 20 67 a number, you g
13f80 61 76 65 3a 20 22 20 28 63 61 72 20 72 65 6d 61 ave: " (car rema
13f90 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 rgs)).
13fa0 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
13fb0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13fc0 20 28 69 66 20 28 6e 6f 74 20 28 69 73 2d 70 6f (if (not (is-po
13fd0 72 74 2d 69 6e 2d 75 73 65 20 70 6f 72 74 6e 75 rt-in-use portnu
13fe0 6d 29 29 20 20 0a 20 20 20 20 20 20 20 20 20 20 m)) .
13ff0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
14000 74 2a 20 28 28 72 65 70 20 20 20 20 20 20 20 28 t* ((rep (
14010 73 74 61 72 74 2d 6e 6e 2d 73 65 72 76 65 72 20 start-nn-server
14020 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 20 20 portnum)).
14030 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14040 20 20 20 20 20 20 20 20 28 6d 74 63 6f 6e 66 64 (mtconfd
14050 61 74 20 28 73 69 6d 70 6c 65 2d 73 65 74 75 70 at (simple-setup
14060 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
14070 2d 73 74 61 72 74 2d 64 69 72 22 29 29 29 0a 20 -start-dir"))).
14080 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14090 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 74 (mt
140a0 63 6f 6e 66 20 20 20 20 28 63 61 72 20 6d 74 63 conf (car mtc
140b0 6f 6e 66 64 61 74 29 29 0a 20 20 20 20 20 20 20 onfdat)).
140c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
140d0 20 20 20 20 20 20 20 28 63 6f 6e 74 61 63 74 20 (contact
140e0 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
140f0 70 20 6d 74 63 6f 6e 66 20 22 6c 69 73 74 65 6e p mtconf "listen
14100 65 72 22 20 22 6f 77 6e 65 72 22 29 29 0a 20 20 er" "owner")).
14110 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14120 20 20 20 20 20 20 20 20 20 20 20 20 28 73 63 72 (scr
14130 69 70 74 20 20 20 20 28 63 6f 6e 66 69 67 66 3a ipt (configf:
14140 6c 6f 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 6c lookup mtconf "l
14150 69 73 74 65 6e 65 72 22 20 22 73 63 72 69 70 74 istener" "script
14160 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 "))).
14170 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
14180 72 69 6e 74 20 22 4c 69 73 74 65 6e 69 6e 67 20 rint "Listening
14190 6f 6e 20 70 6f 72 74 20 22 20 70 6f 72 74 6e 75 on port " portnu
141a0 6d 20 22 20 66 6f 72 20 6d 65 73 73 61 67 65 73 m " for messages
141b0 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 .").
141c0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
141d0 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 t-signal-handler
141e0 21 20 73 69 67 6e 61 6c 2f 69 6e 74 20 20 28 6c ! signal/int (l
141f0 61 6d 62 64 61 20 28 73 69 67 6e 75 6d 29 20 0a ambda (signum) .
14200 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 28 ...............(
14210 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 set! *time-to-ex
14220 69 74 2a 20 23 74 29 0a 20 20 09 09 09 09 09 09 it* #t). ......
14230 09 09 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 ........(debug:p
14240 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
14250 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
14260 22 52 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c "Received signal
14270 20 22 20 73 69 67 6e 75 6d 20 22 20 73 65 6e 64 " signum " send
14280 69 6e 67 20 65 6d 61 69 6c 20 62 65 66 6f 72 20 ing email befor
14290 65 78 69 74 69 6e 67 20 21 21 22 29 0a 20 20 09 exiting !!"). .
142a0 09 09 09 09 09 09 09 09 09 09 09 09 09 28 6c 65 .............(le
142b0 74 20 28 28 65 6d 61 69 6c 2d 62 6f 64 79 20 28 t ((email-body (
142c0 6d 74 75 74 3a 73 74 6d 6c 2d 3e 73 74 72 69 6e mtut:stml->strin
142d0 67 20 28 73 3a 62 6f 64 79 0a 09 09 09 09 09 09 g (s:body.......
142e0 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
142f0 28 73 3a 70 20 28 63 6f 6e 63 20 22 52 65 63 65 (s:p (conc "Rece
14300 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 69 ived signal " si
14310 67 6e 75 6d 20 22 2e 20 4c 69 73 74 65 72 20 68 gnum ". Lister h
14320 61 73 20 62 65 65 6e 20 74 65 72 6d 69 6e 61 74 as been terminat
14330 65 64 20 6f 6e 20 68 6f 73 74 20 22 20 28 67 65 ed on host " (ge
14340 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
14350 72 69 61 62 6c 65 20 22 48 4f 53 54 22 29 20 22 riable "HOST") "
14360 2e 20 22 29 29 29 29 29 29 0a 20 20 20 20 20 20 . ")))))).
14370 20 20 20 20 20 20 20 09 09 09 09 09 20 20 20 20 .....
14380 20 20 20 20 28 73 65 6e 64 6d 61 69 6c 20 63 6f (sendmail co
14390 6e 74 61 63 74 20 22 4c 69 73 74 6e 65 72 20 68 ntact "Listner h
143a0 61 73 20 62 65 65 6e 20 74 65 72 6d 69 6e 61 74 as been terminat
143b0 65 64 2e 22 20 65 6d 61 69 6c 2d 62 6f 64 79 20 ed." email-body
143c0 20 75 73 65 5f 68 74 6d 6c 3a 20 23 74 29 29 0a use_html: #t)).
143d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
143f0 78 69 74 29 29 29 0a 09 09 09 09 09 09 09 09 09 xit)))..........
14400 09 09 09 09 09 09 28 73 65 74 2d 73 69 67 6e 61 ......(set-signa
14410 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 l-handler! signa
14420 6c 2f 74 65 72 6d 20 20 28 6c 61 6d 62 64 61 20 l/term (lambda
14430 28 73 69 67 6e 75 6d 29 20 0a 09 09 09 09 09 09 (signum) .......
14440 09 09 09 09 09 09 09 09 09 28 73 65 74 21 20 2a .........(set! *
14450 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
14460 29 0a 20 20 09 09 09 09 09 09 09 09 09 09 09 09 ). ............
14470 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
14480 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
14490 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 log-port* "Recei
144a0 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 69 67 ved signal " sig
144b0 6e 75 6d 20 22 20 73 65 6e 64 69 6e 67 20 65 6d num " sending em
144c0 61 69 6c 20 62 65 66 6f 72 20 65 78 69 74 69 6e ail befor exitin
144d0 67 20 21 21 22 29 0a 20 20 09 09 09 09 09 09 09 g !!"). .......
144e0 09 09 09 09 09 09 09 28 6c 65 74 20 28 28 65 6d .......(let ((em
144f0 61 69 6c 2d 62 6f 64 79 20 28 6d 74 75 74 3a 73 ail-body (mtut:s
14500 74 6d 6c 2d 3e 73 74 72 69 6e 67 20 28 73 3a 62 tml->string (s:b
14510 6f 64 79 0a 09 09 09 09 09 09 09 09 09 09 09 09 ody.............
14520 09 09 09 09 09 09 09 09 09 09 28 73 3a 70 20 28 ..........(s:p (
14530 63 6f 6e 63 20 22 52 65 63 65 69 76 65 64 20 73 conc "Received s
14540 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
14550 2e 20 4c 69 73 74 65 72 20 68 61 73 20 62 65 65 . Lister has bee
14560 6e 20 74 65 72 6d 69 6e 61 74 65 64 20 6f 6e 20 n terminated on
14570 68 6f 73 74 20 22 20 28 67 65 74 2d 65 6e 76 69 host " (get-envi
14580 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
14590 20 22 48 4f 53 54 22 29 20 22 2e 20 22 29 29 29 "HOST") ". ")))
145a0 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
145b0 20 09 09 09 09 09 20 20 20 20 20 20 20 20 28 73 ..... (s
145c0 65 6e 64 6d 61 69 6c 20 63 6f 6e 74 61 63 74 20 endmail contact
145d0 22 4c 69 73 74 6e 65 72 20 68 61 73 20 62 65 65 "Listner has bee
145e0 6e 20 74 65 72 6d 69 6e 61 74 65 64 2e 22 20 65 n terminated." e
145f0 6d 61 69 6c 2d 62 6f 64 79 20 20 75 73 65 5f 68 mail-body use_h
14600 74 6d 6c 3a 20 23 74 29 29 0a 20 20 20 20 20 20 tml: #t)).
14610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14620 20 20 20 20 20 20 20 20 28 65 78 69 74 29 29 29 (exit)))
14630 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
14640 20 20 20 20 20 20 20 20 20 20 20 3b 28 73 65 74 ;(set
14650 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 -signal-handler!
14660 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 70 65 signal/term spe
14670 63 69 61 6c 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 cial-signal-hand
14680 6c 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 ler).
14690 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
146a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146b0 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f (let loo
146c0 70 20 28 28 69 6e 73 74 72 20 28 6e 6e 2d 72 65 p ((instr (nn-re
146d0 63 76 20 72 65 70 29 29 29 0a 20 20 20 20 20 20 cv rep))).
146e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146f0 20 20 20 20 20 20 20 28 6e 6e 2d 73 65 6e 64 20 (nn-send
14700 72 65 70 20 22 6f 6b 22 29 0a 20 20 20 20 20 20 rep "ok").
14710 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14720 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 74 (let ((ct
14730 69 6d 65 20 28 64 61 74 65 2d 3e 73 74 72 69 6e ime (date->strin
14740 67 20 28 63 75 72 72 65 6e 74 2d 64 61 74 65 29 g (current-date)
14750 29 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ))) .
14760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14770 20 20 28 69 66 20 20 28 65 71 75 61 6c 3f 20 69 (if (equal? i
14780 6e 73 74 72 20 22 74 69 6d 65 2d 74 6f 2d 64 69 nstr "time-to-di
14790 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e").
147a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
147b0 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 (begin .
147c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
147d0 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
147e0 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
147f0 6c 6f 67 2d 70 6f 72 74 2a 20 63 74 69 6d 65 20 log-port* ctime
14800 22 20 72 65 63 65 69 76 65 64 20 27 22 20 69 6e " received '" in
14810 73 74 72 20 22 27 2e 20 54 69 6d 65 20 74 6f 20 str "'. Time to
14820 73 75 63 69 64 65 2e 22 20 29 0a 20 20 20 20 20 sucide." ).
14830 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14840 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
14850 28 70 69 64 20 20 28 63 75 72 72 65 6e 74 2d 70 (pid (current-p
14860 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 20 20 20 rocess-id))).
14870 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14880 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
14890 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
148a0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 69 lt-log-port* "Ki
148b0 6c 6c 69 6e 67 20 63 75 72 72 65 6e 74 20 70 72 lling current pr
148c0 6f 63 65 73 73 20 28 70 69 64 3d 22 20 70 69 64 ocess (pid=" pid
148d0 20 22 29 22 29 0a 20 20 20 20 20 20 20 20 20 20 ")").
148e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
148f0 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f (system (co
14900 6e 63 20 22 6b 69 6c 6c 20 22 20 70 69 64 29 29 nc "kill " pid))
14910 29 29 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 )) .
14920 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14930 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 (begin........
14940 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
14950 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14960 74 2a 20 63 74 69 6d 65 20 22 20 72 65 63 65 69 t* ctime " recei
14970 76 65 64 20 22 20 69 6e 73 74 72 20 29 0a 09 09 ved " instr )...
14980 09 09 09 09 09 09 3b 28 6e 6e 2d 73 65 6e 64 20 ......;(nn-send
14990 72 65 70 20 22 6f 6b 22 29 0a 20 20 20 20 20 20 rep "ok").
149a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
149b0 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
149c0 6f 74 20 28 65 71 75 61 6c 3f 20 69 6e 73 74 72 ot (equal? instr
149d0 20 22 70 69 6e 67 22 29 29 0a 20 20 20 20 20 20 "ping")).
149e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
149f0 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
14a00 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
14a10 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14a20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
14a30 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
14a40 67 2d 70 6f 72 74 2a 20 63 74 69 6d 65 20 22 20 g-port* ctime "
14a50 72 75 6e 6e 69 6e 67 20 5c 22 22 20 73 63 72 69 running \"" scri
14a60 70 74 20 22 20 22 20 69 6e 73 74 72 20 22 5c 22 pt " " instr "\"
14a70 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
14a80 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14a90 20 20 20 20 20 20 20 20 20 28 73 79 73 74 65 6d (system
14aa0 20 28 63 6f 6e 63 20 73 63 72 69 70 74 20 22 20 (conc script "
14ab0 27 22 20 69 6e 73 74 72 20 22 27 20 26 22 29 29 '" instr "' &"))
14ac0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
14ad0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14ae0 20 20 20 20 20 20 20 3b 28 70 72 6f 63 65 73 73 ;(process
14af0 2d 72 75 6e 20 73 63 72 69 70 74 20 28 6c 69 73 -run script (lis
14b00 74 20 20 69 6e 73 74 72 20 29 29 20 20 0a 20 20 t instr )) .
14b10 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14b20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14b30 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
14b40 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
14b50 6f 72 74 2a 20 63 74 69 6d 65 20 22 20 64 6f 6e ort* ctime " don
14b60 65 22 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 e" )).
14b70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14b80 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
14b90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14ba0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14bb0 20 20 20 09 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
14bc0 71 75 61 6c 3f 20 69 6e 73 74 72 20 22 6c 6f 61 qual? instr "loa
14bd0 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d")).
14be0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14bf0 20 20 20 20 20 20 20 20 09 20 09 28 70 72 69 6e . .(prin
14c00 74 20 22 43 68 65 63 6b 69 6e 67 20 6c 6f 61 64 t "Checking load
14c10 22 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")..
14c20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14c30 20 20 20 20 20 20 20 09 20 29 20 0a 20 20 20 20 . ) .
14c40 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14c50 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 )
14c60 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
14c70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14c80 20 20 20 20 29 0a 0a 20 20 20 20 20 20 20 20 20 )..
14c90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14ca0 20 20 20 20 20 20 20 29 29 29 0a 20 20 20 20 20 ))).
14cb0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14cc0 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 6e 6e 2d (loop (nn-
14cd0 72 65 63 76 20 72 65 70 29 29 29 29 0a 09 09 20 recv rep))))...
14ce0 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 (print "ER
14cf0 52 4f 52 3a 20 50 6f 72 74 20 22 20 70 6f 72 74 ROR: Port " port
14d00 6e 75 6d 20 22 20 61 6c 72 65 61 64 79 20 69 6e num " already in
14d10 20 75 73 65 2e 20 54 72 79 20 61 6e 6f 74 68 65 use. Try anothe
14d20 72 20 70 6f 72 74 22 29 29 29 29 29 29 29 0a 20 r port"))))))).
14d30 20 20 20 20 20 28 28 67 61 74 68 65 72 29 20 3b ((gather) ;
14d40 3b 20 67 61 74 68 65 72 20 61 6c 6c 20 61 72 65 ; gather all are
14d50 61 20 64 62 27 73 20 69 6e 74 6f 20 2f 74 6d 70 a db's into /tmp
14d60 2f 24 55 53 45 52 5f 6d 65 67 61 74 65 73 74 2f /$USER_megatest/
14d70 61 6c 6c 64 62 73 0a 20 20 20 20 20 20 20 28 6c alldbs. (l
14d80 65 74 2a 20 28 28 6d 74 63 6f 6e 66 64 61 74 20 et* ((mtconfdat
14d90 28 73 69 6d 70 6c 65 2d 73 65 74 75 70 20 28 61 (simple-setup (a
14da0 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 rgs:get-arg "-st
14db0 61 72 74 2d 64 69 72 22 29 29 29 0a 20 20 20 20 art-dir"))).
14dc0 20 20 20 20 20 20 20 20 20 20 28 6d 74 63 6f 6e (mtcon
14dd0 66 20 20 20 20 28 63 61 72 20 6d 74 63 6f 6e 66 f (car mtconf
14de0 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 dat)).
14df0 20 20 20 20 28 61 72 65 61 73 20 20 20 20 20 28 (areas (
14e00 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 73 20 6d get-area-names m
14e10 74 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 20 20 tconf))).
14e20 20 20 28 70 72 69 6e 74 20 22 61 72 65 61 73 3a (print "areas:
14e30 20 22 20 61 72 65 61 73 29 29 29 0a 20 20 20 20 " areas))).
14e40 20 20 0a 20 20 20 20 20 20 28 65 6c 73 65 0a 20 . (else.
14e50 20 20 20 20 20 20 28 6c 65 74 20 28 28 61 6c 6c (let ((all
14e60 2d 61 63 74 69 6f 6e 73 20 28 73 6f 72 74 20 28 -actions (sort (
14e70 6d 61 70 20 63 6f 6e 63 20 28 64 65 6c 65 74 65 map conc (delete
14e80 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 -duplicates (app
14e90 65 6e 64 20 2a 6f 74 68 65 72 2d 61 63 74 69 6f end *other-actio
14ea0 6e 73 2a 20 28 6d 61 70 20 63 61 72 20 2a 61 63 ns* (map car *ac
14eb0 74 69 6f 6e 2d 6b 65 79 73 2a 29 29 29 29 20 73 tion-keys*)))) s
14ec0 74 72 69 6e 67 3c 3d 3f 29 29 29 0a 09 20 28 70 tring<=?))).. (p
14ed0 72 69 6e 74 20 22 75 6e 72 65 63 6f 67 6e 69 73 rint "unrecognis
14ee0 65 64 20 61 63 74 69 6f 6e 3a 20 5c 22 22 20 2a ed action: \"" *
14ef0 61 63 74 69 6f 6e 2a 20 22 5c 22 2c 20 74 72 79 action* "\", try
14f00 20 6f 6e 65 20 6f 66 3b 20 5c 22 22 20 28 73 74 one of; \"" (st
14f10 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
14f20 20 61 6c 6c 2d 61 63 74 69 6f 6e 73 20 22 5c 22 all-actions "\"
14f30 2c 20 5c 22 22 29 20 22 5c 22 22 29 29 29 0a 20 , \"") "\""))).
14f40 20 20 20 20 20 0a 20 20 20 20 20 20 29 29 20 3b . )) ;
14f50 3b 20 74 68 65 20 65 6e 64 0a 20 20 20 20 20 20 ; the end.
14f60 20 20 20 20 20 20 20 0a 0a 3b 3b 20 49 66 20 48 ..;; If H
14f70 54 54 50 5f 48 4f 53 54 20 69 73 20 64 65 66 69 TTP_HOST is defi
14f80 6e 65 64 20 74 68 65 6e 20 77 65 20 6d 75 73 74 ned then we must
14f90 20 62 65 20 69 6e 20 74 68 65 20 63 67 69 20 65 be in the cgi e
14fa0 6e 76 69 72 6f 6e 6d 65 6e 74 0a 3b 3b 20 73 6f nvironment.;; so
14fb0 20 72 75 6e 20 73 74 6d 6c 20 61 6e 64 20 65 78 run stml and ex
14fc0 69 74 0a 3b 3b 0a 28 69 66 20 28 67 65 74 2d 65 it.;;.(if (get-e
14fd0 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
14fe0 62 6c 65 20 22 48 54 54 50 5f 48 4f 53 54 22 29 ble "HTTP_HOST")
14ff0 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 . (begin.
15000 20 20 28 73 74 6d 6c 3a 6d 61 69 6e 20 23 66 29 (stml:main #f)
15010 0a 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a . (exit))).
15020 0a 28 69 66 20 28 6f 72 20 28 61 72 67 73 3a 67 .(if (or (args:g
15030 65 74 2d 61 72 67 20 22 2d 72 65 70 6c 22 29 0a et-arg "-repl").
15040 09 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 .(args:get-arg "
15050 2d 6c 6f 61 64 22 29 29 0a 20 20 20 20 28 62 65 -load")). (be
15060 67 69 6e 0a 20 20 20 20 20 20 28 69 6d 70 6f 72 gin. (impor
15070 74 20 65 78 74 72 61 73 29 20 3b 3b 20 6d 69 67 t extras) ;; mig
15080 68 74 20 6e 6f 74 20 62 65 20 6e 65 65 64 65 64 ht not be needed
15090 0a 20 20 20 20 20 20 3b 3b 20 28 69 6d 70 6f 72 . ;; (impor
150a0 74 20 63 73 69 29 0a 20 20 20 20 20 20 28 69 6d t csi). (im
150b0 70 6f 72 74 20 72 65 61 64 6c 69 6e 65 29 0a 20 port readline).
150c0 20 20 20 20 20 28 69 6d 70 6f 72 74 20 61 70 72 (import apr
150d0 6f 70 6f 73 29 0a 20 20 20 20 20 20 3b 3b 20 28 opos). ;; (
150e0 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 import (prefix s
150f0 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 qlite3 sqlite3:)
15100 29 20 3b 3b 20 64 6f 65 73 6e 27 74 20 77 6f 72 ) ;; doesn't wor
15110 6b 20 2e 2e 2e 0a 20 20 20 20 20 20 0a 20 20 20 k .... .
15120 20 20 20 28 69 6e 73 74 61 6c 6c 2d 68 69 73 74 (install-hist
15130 6f 72 79 2d 66 69 6c 65 20 28 67 65 74 2d 65 6e ory-file (get-en
15140 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
15150 6c 65 20 22 48 4f 4d 45 22 29 20 22 2e 6d 74 75 le "HOME") ".mtu
15160 74 69 6c 5f 68 69 73 74 6f 72 79 22 29 20 3b 3b til_history") ;;
15170 20 20 5b 68 6f 6d 65 64 69 72 5d 20 5b 66 69 6c [homedir] [fil
15180 65 6e 61 6d 65 5d 20 5b 6e 6c 69 6e 65 73 5d 29 ename] [nlines])
15190 0a 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d . (current-
151a0 69 6e 70 75 74 2d 70 6f 72 74 20 28 6d 61 6b 65 input-port (make
151b0 2d 72 65 61 64 6c 69 6e 65 2d 70 6f 72 74 20 22 -readline-port "
151c0 6d 74 75 74 69 6c 3e 20 22 29 29 0a 20 20 20 20 mtutil> ")).
151d0 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
151e0 61 72 67 20 22 2d 72 65 70 6c 22 29 0a 09 20 20 arg "-repl")..
151f0 28 72 65 70 6c 29 0a 09 20 20 28 6c 6f 61 64 20 (repl).. (load
15200 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
15210 6c 6f 61 64 22 29 29 29 29 29 0a 0a 23 7c 0a 28 load")))))..#|.(
15220 64 65 66 69 6e 65 20 6d 74 63 6f 6e 66 20 28 63 define mtconf (c
15230 61 72 20 28 73 69 6d 70 6c 65 2d 73 65 74 75 70 ar (simple-setup
15240 20 23 66 29 29 29 0a 28 64 65 66 69 6e 65 20 64 #f))).(define d
15250 61 74 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d at (common:with-
15260 71 75 65 75 65 2d 64 62 20 6d 74 63 6f 6e 66 20 queue-db mtconf
15270 28 6c 61 6d 62 64 61 20 28 63 6f 6e 6e 29 28 67 (lambda (conn)(g
15280 65 74 2d 70 6b 74 73 20 63 6f 6e 6e 20 27 28 29 et-pkts conn '()
15290 29 29 29 29 0a 28 70 70 20 28 70 6b 74 73 23 66 )))).(pp (pkts#f
152a0 6c 61 74 74 65 6e 2d 61 6c 6c 20 64 61 74 20 27 latten-all dat '
152b0 28 28 63 6d 64 20 2e 20 28 28 70 61 72 65 6e 74 ((cmd . ((parent
152c0 20 2e 20 50 29 28 75 72 6c 20 2e 20 4d 29 29 29 . P)(url . M)))
152d0 28 72 75 6e 74 79 70 65 20 2e 20 28 28 70 61 72 (runtype . ((par
152e0 65 6e 74 20 2e 20 50 29 29 29 29 20 27 69 64 20 ent . P)))) 'id
152f0 27 67 72 6f 75 70 2d 69 64 20 27 75 75 69 64 20 'group-id 'uuid
15300 27 70 61 72 65 6e 74 20 27 70 6b 74 2d 74 79 70 'parent 'pkt-typ
15310 65 20 27 70 6b 74 20 27 70 72 6f 63 65 73 73 65 e 'pkt 'processe
15320 64 29 29 0a 7c 23 0a d)).|#.