Artifact
d9393dba52b4931da006f12e1d3c30eb76e846d8:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d ==========..;;==
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 0a 3b 3b 20 43 6f 6e 66 69 67 20 66 ====.;; Config f
0230: 69 6c 65 20 68 61 6e 64 6c 69 6e 67 0a 3b 3b 3d ile handling.;;=
0240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0280: 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 72 65 67 65 =====..(use rege
0290: 78 20 72 65 67 65 78 2d 63 61 73 65 29 20 3b 3b x regex-case) ;;
02a0: 20 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c directory-util
02b0: 73 29 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 s).(declare (uni
02c0: 74 20 63 6f 6e 66 69 67 66 29 29 0a 28 64 65 63 t configf)).(dec
02d0: 6c 61 72 65 20 28 75 73 65 73 20 70 72 6f 63 65 lare (uses proce
02e0: 73 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 ss)).(declare (u
02f0: 73 65 73 20 65 6e 76 29 29 0a 0a 28 69 6e 63 6c ses env))..(incl
0300: 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f ude "common_reco
0310: 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 72 65 rds.scm")..;; re
0320: 74 75 72 6e 20 6c 69 73 74 20 28 70 61 74 68 20 turn list (path
0330: 66 75 6c 6c 70 61 74 68 20 63 6f 6e 66 69 67 6e fullpath confign
0340: 61 6d 65 29 0a 28 64 65 66 69 6e 65 20 28 66 69 ame).(define (fi
0350: 6e 64 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 nd-config config
0360: 6e 61 6d 65 20 23 21 6b 65 79 20 28 74 6f 70 70 name #!key (topp
0370: 61 74 68 20 23 66 29 29 0a 20 20 28 69 66 20 74 ath #f)). (if t
0380: 6f 70 70 61 74 68 0a 20 20 20 20 20 20 28 6c 65 oppath. (le
0390: 74 20 28 28 63 66 6e 61 6d 65 20 28 63 6f 6e 63 t ((cfname (conc
03a0: 20 74 6f 70 70 61 74 68 20 22 2f 22 20 63 6f 6e toppath "/" con
03b0: 66 69 67 6e 61 6d 65 29 29 29 0a 09 28 69 66 20 figname)))..(if
03c0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 66 (file-exists? cf
03d0: 6e 61 6d 65 29 0a 09 20 20 20 20 28 6c 69 73 74 name).. (list
03e0: 20 74 6f 70 70 61 74 68 20 63 66 6e 61 6d 65 20 toppath cfname
03f0: 63 6f 6e 66 69 67 6e 61 6d 65 29 0a 09 20 20 20 configname)..
0400: 20 28 6c 69 73 74 20 23 66 20 20 20 20 20 20 23 (list #f #
0410: 66 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 f #f))).
0420: 20 20 28 6c 65 74 2a 20 28 28 63 77 64 20 28 73 (let* ((cwd (s
0430: 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 75 72 tring-split (cur
0440: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 20 rent-directory)
0450: 22 2f 22 29 29 29 0a 09 28 6c 65 74 20 6c 6f 6f "/")))..(let loo
0460: 70 20 28 28 64 69 72 20 63 77 64 29 29 0a 09 20 p ((dir cwd))..
0470: 20 28 6c 65 74 2a 20 28 28 70 61 74 68 20 20 20 (let* ((path
0480: 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 (conc "/" (str
0490: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
04a0: 64 69 72 20 22 2f 22 29 29 29 0a 09 09 20 28 66 dir "/")))... (f
04b0: 75 6c 6c 70 61 74 68 20 28 63 6f 6e 63 20 70 61 ullpath (conc pa
04c0: 74 68 20 22 2f 22 20 63 6f 6e 66 69 67 6e 61 6d th "/" confignam
04d0: 65 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 66 e))).. (if (f
04e0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c ile-exists? full
04f0: 70 61 74 68 29 0a 09 09 28 6c 69 73 74 20 70 61 path)...(list pa
0500: 74 68 20 66 75 6c 6c 70 61 74 68 20 63 6f 6e 66 th fullpath conf
0510: 69 67 6e 61 6d 65 29 0a 09 09 28 6c 65 74 20 28 igname)...(let (
0520: 28 72 65 6d 63 77 64 20 28 74 61 6b 65 20 64 69 (remcwd (take di
0530: 72 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 69 72 r (- (length dir
0540: 29 20 31 29 29 29 29 0a 09 09 20 20 28 69 66 20 ) 1))))... (if
0550: 28 6e 75 6c 6c 3f 20 72 65 6d 63 77 64 29 0a 09 (null? remcwd)..
0560: 09 20 20 20 20 20 20 28 6c 69 73 74 20 23 66 20 . (list #f
0570: 23 66 20 23 66 29 20 3b 3b 20 20 23 66 20 23 66 #f #f) ;; #f #f
0580: 29 20 0a 09 09 20 20 28 6c 6f 6f 70 20 72 65 6d ) ... (loop rem
0590: 63 77 64 29 29 29 29 29 29 29 29 29 0a 0a 28 64 cwd)))))))))..(d
05a0: 65 66 69 6e 65 20 28 63 6f 6e 66 69 67 3a 61 73 efine (config:as
05b0: 73 6f 63 2d 73 61 66 65 2d 61 64 64 20 61 6c 69 soc-safe-add ali
05c0: 73 74 20 6b 65 79 20 76 61 6c 20 23 21 6b 65 79 st key val #!key
05d0: 20 28 6d 65 74 61 64 61 74 61 20 23 66 29 29 0a (metadata #f)).
05e0: 20 20 28 6c 65 74 20 28 28 6e 65 77 61 6c 69 73 (let ((newalis
05f0: 74 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 t (filter (lambd
0600: 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c a (x)(not (equal
0610: 3f 20 6b 65 79 20 28 63 61 72 20 78 29 29 29 29 ? key (car x))))
0620: 20 61 6c 69 73 74 29 29 29 0a 20 20 20 20 28 61 alist))). (a
0630: 70 70 65 6e 64 20 6e 65 77 61 6c 69 73 74 20 28 ppend newalist (
0640: 6c 69 73 74 20 28 69 66 20 6d 65 74 61 64 61 74 list (if metadat
0650: 61 0a 09 09 09 20 20 20 20 20 20 20 28 6c 69 73 a.... (lis
0660: 74 20 6b 65 79 20 76 61 6c 20 6d 65 74 61 64 61 t key val metada
0670: 74 61 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c ta).... (l
0680: 69 73 74 20 6b 65 79 20 76 61 6c 29 29 29 29 29 ist key val)))))
0690: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 )..(define (conf
06a0: 69 67 3a 65 76 61 6c 2d 73 74 72 69 6e 67 2d 69 ig:eval-string-i
06b0: 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 73 74 n-environment st
06c0: 72 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 r). (handle-exc
06d0: 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 eptions. exn.
06e0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 64 (begin. (d
06f0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
0700: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0710: 70 6f 72 74 2a 20 22 70 72 6f 62 6c 65 6d 20 65 port* "problem e
0720: 76 61 6c 75 61 74 69 6e 67 20 5c 22 22 20 73 74 valuating \"" st
0730: 72 20 22 5c 22 20 69 6e 20 74 68 65 20 73 68 65 r "\" in the she
0740: 6c 6c 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 22 29 ll environment")
0750: 0a 20 20 20 20 20 23 66 29 0a 20 20 20 28 6c 65 . #f). (le
0760: 74 20 28 28 63 6d 64 72 65 73 20 28 70 72 6f 63 t ((cmdres (proc
0770: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 ess:cmd-run->lis
0780: 74 20 28 63 6f 6e 63 20 22 65 63 68 6f 20 22 20 t (conc "echo "
0790: 73 74 72 29 29 29 29 0a 20 20 20 20 20 28 69 66 str)))). (if
07a0: 20 28 6e 75 6c 6c 3f 20 63 6d 64 72 65 73 29 20 (null? cmdres)
07b0: 22 22 0a 09 20 28 63 61 61 72 20 63 6d 64 72 65 "".. (caar cmdre
07c0: 73 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d s)))))..;;======
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 0a 3b 3b 20 4d 61 6b 65 20 74 68 65 20 72 65 67 .;; Make the reg
0820: 65 78 70 27 73 20 6e 65 65 64 65 64 20 67 6c 6f exp's needed glo
0830: 62 61 6c 6c 79 20 61 76 61 69 6c 61 62 6c 65 0a bally available.
0840: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0880: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
0890: 65 20 63 6f 6e 66 69 67 66 3a 69 6e 63 6c 75 64 e configf:includ
08a0: 65 2d 72 78 20 28 72 65 67 65 78 70 20 22 5e 5c e-rx (regexp "^\
08b0: 5c 5b 69 6e 63 6c 75 64 65 5c 5c 73 2b 28 2e 2a \[include\\s+(.*
08c0: 29 5c 5c 5d 5c 5c 73 2a 24 22 29 29 0a 28 64 65 )\\]\\s*$")).(de
08d0: 66 69 6e 65 20 63 6f 6e 66 69 67 66 3a 73 65 63 fine configf:sec
08e0: 74 69 6f 6e 2d 72 78 20 28 72 65 67 65 78 70 20 tion-rx (regexp
08f0: 22 5e 5c 5c 5b 28 2e 2a 29 5c 5c 5d 5c 5c 73 2a "^\\[(.*)\\]\\s*
0900: 24 22 29 29 0a 28 64 65 66 69 6e 65 20 63 6f 6e $")).(define con
0910: 66 69 67 66 3a 62 6c 61 6e 6b 2d 6c 2d 72 78 20 figf:blank-l-rx
0920: 28 72 65 67 65 78 70 20 22 5e 5c 5c 73 2a 24 22 (regexp "^\\s*$"
0930: 29 29 0a 28 64 65 66 69 6e 65 20 63 6f 6e 66 69 )).(define confi
0940: 67 66 3a 6b 65 79 2d 73 79 73 2d 70 72 20 28 72 gf:key-sys-pr (r
0950: 65 67 65 78 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c egexp "^(\\S+)\\
0960: 73 2b 5c 5c 5b 73 79 73 74 65 6d 5c 5c 73 2b 28 s+\\[system\\s+(
0970: 5c 5c 53 2b 2e 2a 29 5c 5c 5d 5c 5c 73 2a 24 22 \\S+.*)\\]\\s*$"
0980: 29 29 0a 28 64 65 66 69 6e 65 20 63 6f 6e 66 69 )).(define confi
0990: 67 66 3a 6b 65 79 2d 76 61 6c 2d 70 72 20 28 72 gf:key-val-pr (r
09a0: 65 67 65 78 70 20 22 5e 28 5c 5c 53 2b 29 28 5c egexp "^(\\S+)(\
09b0: 5c 73 2b 28 2e 2a 29 7c 28 29 29 24 22 29 29 0a \s+(.*)|())$")).
09c0: 28 64 65 66 69 6e 65 20 63 6f 6e 66 69 67 66 3a (define configf:
09d0: 6b 65 79 2d 6e 6f 2d 76 61 6c 20 28 72 65 67 65 key-no-val (rege
09e0: 78 70 20 22 5e 28 5c 5c 53 2b 29 28 5c 5c 73 2a xp "^(\\S+)(\\s*
09f0: 29 24 22 29 29 0a 28 64 65 66 69 6e 65 20 63 6f )$")).(define co
0a00: 6e 66 69 67 66 3a 63 6f 6d 6d 65 6e 74 2d 72 78 nfigf:comment-rx
0a10: 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 73 2a 23 (regexp "^\\s*#
0a20: 2e 2a 22 29 29 0a 28 64 65 66 69 6e 65 20 63 6f .*")).(define co
0a30: 6e 66 69 67 66 3a 63 6f 6e 74 2d 6c 6e 2d 72 78 nfigf:cont-ln-rx
0a40: 20 28 72 65 67 65 78 70 20 22 5e 28 5c 5c 73 2b (regexp "^(\\s+
0a50: 29 28 5c 5c 53 2b 2e 2a 29 24 22 29 29 0a 28 64 )(\\S+.*)$")).(d
0a60: 65 66 69 6e 65 20 63 6f 6e 66 69 67 66 3a 73 65 efine configf:se
0a70: 74 74 69 6e 67 73 20 20 20 28 72 65 67 65 78 70 ttings (regexp
0a80: 20 22 5e 5c 5c 5b 63 6f 6e 66 69 67 66 3a 73 65 "^\\[configf:se
0a90: 74 74 69 6e 67 73 5c 5c 73 2b 28 5c 5c 53 2b 29 ttings\\s+(\\S+)
0aa0: 5c 5c 73 2b 28 5c 5c 53 2b 29 5d 5c 5c 73 2a 24 \\s+(\\S+)]\\s*$
0ab0: 22 29 29 0a 0a 3b 3b 20 72 65 61 64 20 61 20 6c "))..;; read a l
0ac0: 69 6e 65 20 61 6e 64 20 70 72 6f 63 65 73 73 20 ine and process
0ad0: 61 6e 79 20 23 7b 20 2e 2e 2e 20 7d 20 63 6f 6e any #{ ... } con
0ae0: 73 74 72 75 63 74 73 0a 0a 28 64 65 66 69 6e 65 structs..(define
0af0: 20 63 6f 6e 66 69 67 66 3a 76 61 72 2d 65 78 70 configf:var-exp
0b00: 61 6e 64 2d 72 65 67 65 78 20 28 72 65 67 65 78 and-regex (regex
0b10: 70 20 22 5e 28 2e 2a 29 23 5c 5c 7b 28 73 63 68 p "^(.*)#\\{(sch
0b20: 65 6d 65 7c 73 79 73 74 65 6d 7c 73 68 65 6c 6c eme|system|shell
0b30: 7c 67 65 74 65 6e 76 7c 67 65 74 7c 72 75 6e 63 |getenv|get|runc
0b40: 6f 6e 66 69 67 73 2d 67 65 74 7c 72 67 65 74 29 onfigs-get|rget)
0b50: 5c 5c 73 2b 28 5b 5e 5c 5c 7d 5c 5c 7b 5d 2a 29 \\s+([^\\}\\{]*)
0b60: 5c 5c 7d 28 2e 2a 29 22 29 29 0a 0a 28 64 65 66 \\}(.*)"))..(def
0b70: 69 6e 65 20 28 63 6f 6e 66 69 67 66 3a 70 72 6f ine (configf:pro
0b80: 63 65 73 73 2d 6c 69 6e 65 20 6c 20 68 74 20 61 cess-line l ht a
0b90: 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 23 21 6b 65 llow-system #!ke
0ba0: 79 20 28 6c 69 6e 65 6e 75 6d 20 23 66 29 29 0a y (linenum #f)).
0bb0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 65 (let loop ((re
0bc0: 73 20 6c 29 29 0a 20 20 20 20 28 69 66 20 28 73 s l)). (if (s
0bd0: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 28 6c 65 tring? res)..(le
0be0: 74 20 28 28 6d 61 74 63 68 64 61 74 20 28 73 74 t ((matchdat (st
0bf0: 72 69 6e 67 2d 73 65 61 72 63 68 20 63 6f 6e 66 ring-search conf
0c00: 69 67 66 3a 76 61 72 2d 65 78 70 61 6e 64 2d 72 igf:var-expand-r
0c10: 65 67 65 78 20 72 65 73 29 29 29 0a 09 20 20 28 egex res))).. (
0c20: 69 66 20 6d 61 74 63 68 64 61 74 0a 09 20 20 20 if matchdat..
0c30: 20 20 20 28 6c 65 74 2a 20 28 28 70 72 65 73 74 (let* ((prest
0c40: 72 20 20 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 r (list-ref mat
0c50: 63 68 64 61 74 20 31 29 29 0a 09 09 20 20 20 20 chdat 1))...
0c60: 20 28 63 6d 64 74 79 70 65 20 28 6c 69 73 74 2d (cmdtype (list-
0c70: 72 65 66 20 6d 61 74 63 68 64 61 74 20 32 29 29 ref matchdat 2))
0c80: 20 3b 3b 20 65 76 61 6c 2c 20 73 79 73 74 65 6d ;; eval, system
0c90: 2c 20 73 68 65 6c 6c 2c 20 67 65 74 65 6e 76 0a , shell, getenv.
0ca0: 09 09 20 20 20 20 20 28 63 6d 64 20 20 20 20 20 .. (cmd
0cb0: 28 6c 69 73 74 2d 72 65 66 20 6d 61 74 63 68 64 (list-ref matchd
0cc0: 61 74 20 33 29 29 0a 09 09 20 20 20 20 20 28 70 at 3))... (p
0cd0: 6f 73 74 73 74 72 20 28 6c 69 73 74 2d 72 65 66 oststr (list-ref
0ce0: 20 6d 61 74 63 68 64 61 74 20 34 29 29 0a 09 09 matchdat 4))...
0cf0: 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 23 66 (result #f
0d00: 29 0a 09 09 20 20 20 20 20 28 73 74 61 72 74 2d )... (start-
0d10: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
0d20: 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 20 28 conds))... (
0d30: 63 6d 64 73 79 6d 20 20 28 73 74 72 69 6e 67 2d cmdsym (string-
0d40: 3e 73 79 6d 62 6f 6c 20 63 6d 64 74 79 70 65 29 >symbol cmdtype)
0d50: 29 0a 09 09 20 20 20 20 20 28 66 75 6c 6c 63 6d )... (fullcm
0d60: 64 20 28 63 61 73 65 20 63 6d 64 73 79 6d 0a 09 d (case cmdsym..
0d70: 09 09 09 28 28 73 63 68 65 6d 65 29 28 63 6f 6e ...((scheme)(con
0d80: 63 20 22 28 6c 61 6d 62 64 61 20 28 68 74 29 22 c "(lambda (ht)"
0d90: 20 63 6d 64 20 22 29 22 29 29 0a 09 09 09 09 28 cmd ")")).....(
0da0: 28 73 79 73 74 65 6d 29 28 63 6f 6e 63 20 22 28 (system)(conc "(
0db0: 6c 61 6d 62 64 61 20 28 68 74 29 28 73 79 73 74 lambda (ht)(syst
0dc0: 65 6d 20 5c 22 22 20 63 6d 64 20 22 5c 22 29 29 em \"" cmd "\"))
0dd0: 22 29 29 0a 09 09 09 09 28 28 73 68 65 6c 6c 29 ")).....((shell)
0de0: 20 28 63 6f 6e 63 20 22 28 6c 61 6d 62 64 61 20 (conc "(lambda
0df0: 28 68 74 29 28 73 68 65 6c 6c 20 5c 22 22 20 20 (ht)(shell \""
0e00: 63 6d 64 20 22 5c 22 29 29 22 29 29 0a 09 09 09 cmd "\"))"))....
0e10: 09 28 28 67 65 74 65 6e 76 29 28 63 6f 6e 63 20 .((getenv)(conc
0e20: 22 28 6c 61 6d 62 64 61 20 28 68 74 29 28 67 65 "(lambda (ht)(ge
0e30: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
0e40: 72 69 61 62 6c 65 20 5c 22 22 20 63 6d 64 20 22 riable \"" cmd "
0e50: 5c 22 29 29 22 29 29 0a 09 09 09 09 28 28 67 65 \"))")).....((ge
0e60: 74 29 20 20 20 0a 09 09 09 09 20 28 6c 65 74 2a t) ..... (let*
0e70: 20 28 28 70 61 72 74 73 20 28 73 74 72 69 6e 67 ((parts (string
0e80: 2d 73 70 6c 69 74 20 63 6d 64 29 29 0a 09 09 09 -split cmd))....
0e90: 09 09 28 73 65 63 74 20 20 28 63 61 72 20 70 61 ..(sect (car pa
0ea0: 72 74 73 29 29 0a 09 09 09 09 09 28 76 61 72 20 rts))......(var
0eb0: 20 20 28 63 61 64 72 20 70 61 72 74 73 29 29 29 (cadr parts)))
0ec0: 0a 09 09 09 09 20 20 20 28 63 6f 6e 63 20 22 28 ..... (conc "(
0ed0: 6c 61 6d 62 64 61 20 28 68 74 29 28 63 6f 6e 66 lambda (ht)(conf
0ee0: 69 67 2d 6c 6f 6f 6b 75 70 20 68 74 20 5c 22 22 ig-lookup ht \""
0ef0: 20 73 65 63 74 20 22 5c 22 20 5c 22 22 20 76 61 sect "\" \"" va
0f00: 72 20 22 5c 22 29 29 22 29 29 29 0a 09 09 09 09 r "\"))"))).....
0f10: 28 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 ((runconfigs-get
0f20: 29 20 28 63 6f 6e 63 20 22 28 6c 61 6d 62 64 61 ) (conc "(lambda
0f30: 20 28 68 74 29 28 72 75 6e 63 6f 6e 66 69 67 73 (ht)(runconfigs
0f40: 2d 67 65 74 20 68 74 20 5c 22 22 20 63 6d 64 20 -get ht \"" cmd
0f50: 22 5c 22 29 29 22 29 29 0a 09 09 09 09 28 28 72 "\"))")).....((r
0f60: 67 65 74 29 20 20 20 20 20 20 20 20 20 20 20 28 get) (
0f70: 63 6f 6e 63 20 22 28 6c 61 6d 62 64 61 20 28 68 conc "(lambda (h
0f80: 74 29 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 t)(runconfigs-ge
0f90: 74 20 68 74 20 5c 22 22 20 63 6d 64 20 22 5c 22 t ht \"" cmd "\"
0fa0: 29 29 22 29 29 0a 09 09 09 09 28 65 6c 73 65 20 ))")).....(else
0fb0: 22 28 6c 61 6d 62 64 61 20 28 68 74 29 28 70 72 "(lambda (ht)(pr
0fc0: 69 6e 74 20 5c 22 45 52 52 4f 52 5c 22 29 20 5c int \"ERROR\") \
0fd0: 22 45 52 52 4f 52 5c 22 29 22 29 29 29 29 0a 09 "ERROR\")"))))..
0fe0: 09 3b 3b 20 28 70 72 69 6e 74 20 22 66 75 6c 6c .;; (print "full
0ff0: 63 6d 64 3d 22 20 66 75 6c 6c 63 6d 64 29 0a 09 cmd=" fullcmd)..
1000: 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
1010: 6f 6e 73 0a 09 09 20 65 78 6e 0a 09 09 20 28 62 ons... exn... (b
1020: 65 67 69 6e 0a 09 09 20 20 20 28 64 65 62 75 67 egin... (debug
1030: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1040: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
1050: 4e 49 4e 47 3a 20 66 61 69 6c 65 64 20 74 6f 20 NING: failed to
1060: 70 72 6f 63 65 73 73 20 63 6f 6e 66 69 67 20 69 process config i
1070: 6e 70 75 74 20 5c 22 22 20 6c 20 22 5c 22 22 29 nput \"" l "\"")
1080: 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
1090: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
10a0: 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 g-port* " messag
10b0: 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
10c0: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
10d0: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
10e0: 29 20 65 78 6e 29 29 0a 09 09 20 20 20 3b 3b 20 ) exn))... ;;
10f0: 28 70 72 69 6e 74 20 22 65 78 6e 3d 22 20 28 63 (print "exn=" (c
1100: 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 ondition->list e
1110: 78 6e 29 29 0a 09 09 20 20 20 28 73 65 74 21 20 xn))... (set!
1120: 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 22 23 7b result (conc "#{
1130: 28 20 22 20 63 6d 64 74 79 70 65 20 22 29 20 22 ( " cmdtype ") "
1140: 20 63 6d 64 22 7d 22 29 29 29 0a 09 09 20 28 69 cmd"}")))... (i
1150: 66 20 28 6f 72 20 61 6c 6c 6f 77 2d 73 79 73 74 f (or allow-syst
1160: 65 6d 0a 09 09 09 20 28 6e 6f 74 20 28 6d 65 6d em.... (not (mem
1170: 62 65 72 20 63 6d 64 74 79 70 65 20 27 28 22 73 ber cmdtype '("s
1180: 79 73 74 65 6d 22 20 22 73 68 65 6c 6c 22 29 29 ystem" "shell"))
1190: 29 29 0a 09 09 20 20 20 20 20 28 77 69 74 68 2d ))... (with-
11a0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 74 72 69 6e input-from-strin
11b0: 67 20 66 75 6c 6c 63 6d 64 0a 09 09 20 20 20 20 g fullcmd...
11c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
11d0: 09 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 . (set! result (
11e0: 28 65 76 61 6c 20 28 72 65 61 64 29 29 20 68 74 (eval (read)) ht
11f0: 29 29 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 ))))... (set!
1200: 20 72 65 73 75 6c 74 20 28 63 6f 6e 63 20 22 23 result (conc "#
1210: 7b 28 22 20 63 6d 64 74 79 70 65 20 22 29 20 22 {(" cmdtype ") "
1220: 20 20 63 6d 64 20 22 7d 22 29 29 29 29 0a 09 09 cmd "}"))))...
1230: 28 63 61 73 65 20 63 6d 64 73 79 6d 0a 09 09 20 (case cmdsym...
1240: 20 28 28 73 79 73 74 65 6d 20 73 68 65 6c 6c 20 ((system shell
1250: 73 63 68 65 6d 65 29 0a 09 09 20 20 20 28 6c 65 scheme)... (le
1260: 74 20 28 28 64 65 6c 74 61 20 28 2d 20 28 63 75 t ((delta (- (cu
1270: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 rrent-seconds) s
1280: 74 61 72 74 2d 74 69 6d 65 29 29 29 0a 09 09 20 tart-time)))...
1290: 20 20 20 20 28 69 66 20 28 3e 20 64 65 6c 74 61 (if (> delta
12a0: 20 32 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 2).... (debug:p
12b0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
12c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
12d0: 66 6f 72 20 6c 69 6e 65 20 5c 22 22 20 6c 20 22 for line \"" l "
12e0: 5c 22 5c 6e 20 63 6f 6d 6d 61 6e 64 3a 20 20 22 \"\n command: "
12f0: 20 63 6d 64 20 22 20 74 6f 6f 6b 20 22 20 64 65 cmd " took " de
1300: 6c 74 61 20 22 20 73 65 63 6f 6e 64 73 20 74 6f lta " seconds to
1310: 20 72 75 6e 20 77 69 74 68 20 6f 75 74 70 75 74 run with output
1320: 3a 5c 6e 20 20 20 22 20 72 65 73 75 6c 74 29 0a :\n " result).
1330: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
1340: 2d 69 6e 66 6f 20 39 20 2a 64 65 66 61 75 6c 74 -info 9 *default
1350: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 6f 72 20 -log-port* "for
1360: 6c 69 6e 65 20 5c 22 22 20 6c 20 22 5c 22 5c 6e line \"" l "\"\n
1370: 20 63 6f 6d 6d 61 6e 64 3a 20 20 22 20 63 6d 64 command: " cmd
1380: 20 22 20 74 6f 6f 6b 20 22 20 64 65 6c 74 61 20 " took " delta
1390: 22 20 73 65 63 6f 6e 64 73 20 74 6f 20 72 75 6e " seconds to run
13a0: 20 77 69 74 68 20 6f 75 74 70 75 74 3a 5c 6e 20 with output:\n
13b0: 20 20 22 20 72 65 73 75 6c 74 29 29 29 29 29 0a " result))))).
13c0: 09 09 28 6c 6f 6f 70 20 28 63 6f 6e 63 20 70 72 ..(loop (conc pr
13d0: 65 73 74 72 20 72 65 73 75 6c 74 20 70 6f 73 74 estr result post
13e0: 73 74 72 29 29 29 0a 09 20 20 20 20 20 20 72 65 str))).. re
13f0: 73 29 29 0a 09 72 65 73 29 29 29 0a 0a 3b 3b 20 s))..res)))..;;
1400: 52 75 6e 20 61 20 73 68 65 6c 6c 20 63 6f 6d 6d Run a shell comm
1410: 61 6e 64 20 61 6e 64 20 72 65 74 75 72 6e 20 74 and and return t
1420: 68 65 20 6f 75 74 70 75 74 20 61 73 20 61 20 73 he output as a s
1430: 74 72 69 6e 67 0a 28 64 65 66 69 6e 65 20 28 73 tring.(define (s
1440: 68 65 6c 6c 20 63 6d 64 29 0a 20 20 28 6c 65 74 hell cmd). (let
1450: 2a 20 28 28 6f 75 74 70 75 74 20 28 70 72 6f 63 * ((output (proc
1460: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 ess:cmd-run->lis
1470: 74 20 63 6d 64 29 29 0a 09 20 28 72 65 73 20 20 t cmd)).. (res
1480: 20 20 28 63 61 72 20 6f 75 74 70 75 74 29 29 0a (car output)).
1490: 09 20 28 73 74 61 74 75 73 20 28 63 61 64 72 20 . (status (cadr
14a0: 6f 75 74 70 75 74 29 29 29 0a 20 20 20 20 28 69 output))). (i
14b0: 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 f (equal? status
14c0: 20 30 29 0a 09 28 6c 65 74 20 28 28 6f 75 74 72 0)..(let ((outr
14d0: 65 73 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 es (string-inter
14e0: 73 70 65 72 73 65 20 0a 09 09 20 20 20 20 20 20 sperse ...
14f0: 20 72 65 73 0a 09 09 20 20 20 20 20 20 20 22 5c res... "\
1500: 6e 22 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a n"))).. (debug:
1510: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
1520: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1530: 22 73 68 65 6c 6c 20 72 65 73 75 6c 74 3a 5c 6e "shell result:\n
1540: 22 20 6f 75 74 72 65 73 29 0a 09 20 20 6f 75 74 " outres).. out
1550: 72 65 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 res)..(begin..
1560: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
1570: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 65 72 port (current-er
1580: 72 6f 72 2d 70 6f 72 74 29 0a 09 20 20 20 20 28 ror-port).. (
1590: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
15a0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
15b0: 22 20 63 6d 64 20 22 20 72 65 74 75 72 6e 65 64 " cmd " returned
15c0: 20 62 61 64 20 65 78 69 74 20 63 6f 64 65 20 22 bad exit code "
15d0: 20 73 74 61 74 75 73 29 29 29 0a 09 20 20 22 22 status))).. ""
15e0: 29 29 29 29 0a 0a 3b 3b 20 74 68 69 73 20 77 61 ))))..;; this wa
15f0: 73 20 69 6e 6c 69 6e 65 20 62 75 74 20 49 27 6d s inline but I'm
1600: 20 70 72 65 74 74 79 20 73 75 72 65 20 74 68 61 pretty sure tha
1610: 74 20 69 73 20 61 20 68 6f 6c 64 20 6f 76 65 72 t is a hold over
1620: 20 66 72 6f 6d 20 77 68 65 6e 20 69 74 20 77 61 from when it wa
1630: 73 20 2a 76 65 72 79 2a 20 73 69 6d 70 6c 65 20 s *very* simple
1640: 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ....;;.(define (
1650: 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 6c 69 6e configf:read-lin
1660: 65 20 70 20 68 74 20 61 6c 6c 6f 77 2d 70 72 6f e p ht allow-pro
1670: 63 65 73 73 69 6e 67 20 73 65 74 74 69 6e 67 73 cessing settings
1680: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
1690: 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 inl (read-line p
16a0: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 63 ))). (let ((c
16b0: 6f 6e 74 2d 6c 69 6e 65 20 28 61 6e 64 20 28 73 ont-line (and (s
16c0: 74 72 69 6e 67 3f 20 69 6e 6c 29 0a 09 09 09 20 tring? inl)....
16d0: 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d 6e 75 (not (string-nu
16e0: 6c 6c 3f 20 69 6e 6c 29 29 0a 09 09 09 20 20 28 ll? inl)).... (
16f0: 65 71 75 61 6c 3f 20 22 5c 5c 22 20 28 73 74 72 equal? "\\" (str
1700: 69 6e 67 2d 74 61 6b 65 2d 72 69 67 68 74 20 69 ing-take-right i
1710: 6e 6c 20 31 29 29 29 29 29 0a 20 20 20 20 20 20 nl 1))))).
1720: 28 69 66 20 63 6f 6e 74 2d 6c 69 6e 65 20 3b 3b (if cont-line ;;
1730: 20 6c 61 73 74 20 63 68 61 72 61 63 74 65 72 20 last character
1740: 69 73 20 5c 20 0a 09 20 20 28 6c 65 74 20 28 28 is \ .. (let ((
1750: 6e 65 78 74 6c 20 28 72 65 61 64 2d 6c 69 6e 65 nextl (read-line
1760: 20 70 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 p))).. (if (
1770: 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f not (eof-object?
1780: 20 6e 65 78 74 6c 29 29 0a 09 09 28 6c 6f 6f 70 nextl))...(loop
1790: 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 (string-append
17a0: 28 69 66 20 63 6f 6e 74 2d 6c 69 6e 65 20 0a 09 (if cont-line ..
17b0: 09 09 09 09 20 28 73 74 72 69 6e 67 2d 74 61 6b .... (string-tak
17c0: 65 20 69 6e 6c 20 28 2d 20 28 73 74 72 69 6e 67 e inl (- (string
17d0: 2d 6c 65 6e 67 74 68 20 69 6e 6c 29 20 31 29 29 -length inl) 1))
17e0: 0a 09 09 09 09 09 20 69 6e 6c 29 0a 09 09 09 09 ...... inl).....
17f0: 20 20 20 20 20 6e 65 78 74 6c 29 29 29 29 0a 09 nextl))))..
1800: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 63 61 (let ((res (ca
1810: 73 65 20 61 6c 6c 6f 77 2d 70 72 6f 63 65 73 73 se allow-process
1820: 69 6e 67 20 3b 3b 20 69 66 20 28 61 6e 64 20 61 ing ;; if (and a
1830: 6c 6c 6f 77 2d 70 72 6f 63 65 73 73 69 6e 67 20 llow-processing
1840: 0a 09 09 20 20 20 20 20 20 20 3b 3b 09 20 20 20 ... ;;.
1850: 28 6e 6f 74 20 28 65 71 3f 20 61 6c 6c 6f 77 2d (not (eq? allow-
1860: 70 72 6f 63 65 73 73 69 6e 67 20 27 72 65 74 75 processing 'retu
1870: 72 6e 2d 73 74 72 69 6e 67 29 29 29 0a 09 09 20 rn-string)))...
1880: 20 20 20 20 20 20 28 28 23 74 20 23 66 29 0a 09 ((#t #f)..
1890: 09 09 28 63 6f 6e 66 69 67 66 3a 70 72 6f 63 65 ..(configf:proce
18a0: 73 73 2d 6c 69 6e 65 20 69 6e 6c 20 68 74 20 61 ss-line inl ht a
18b0: 6c 6c 6f 77 2d 70 72 6f 63 65 73 73 69 6e 67 29 llow-processing)
18c0: 29 0a 09 09 20 20 20 20 20 20 20 28 28 72 65 74 )... ((ret
18d0: 75 72 6e 2d 73 74 72 69 6e 67 29 0a 09 09 09 69 urn-string)....i
18e0: 6e 6c 29 0a 09 09 20 20 20 20 20 20 20 28 65 6c nl)... (el
18f0: 73 65 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 70 se....(configf:p
1900: 72 6f 63 65 73 73 2d 6c 69 6e 65 20 69 6e 6c 20 rocess-line inl
1910: 68 74 20 61 6c 6c 6f 77 2d 70 72 6f 63 65 73 73 ht allow-process
1920: 69 6e 67 29 29 29 29 29 0a 09 20 20 20 20 28 69 ing))))).. (i
1930: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 f (and (string?
1940: 72 65 73 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 res)... (not
1950: 20 28 65 71 75 61 6c 3f 20 28 68 61 73 68 2d 74 (equal? (hash-t
1960: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1970: 20 73 65 74 74 69 6e 67 73 20 22 74 72 69 6d 2d settings "trim-
1980: 74 72 61 69 6c 69 6e 67 2d 73 70 61 63 65 73 22 trailing-spaces"
1990: 20 22 6e 6f 22 29 20 22 6e 6f 22 29 29 29 0a 09 "no") "no")))..
19a0: 09 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 .(string-substit
19b0: 75 74 65 20 22 5c 5c 73 2b 24 22 20 22 22 20 72 ute "\\s+$" "" r
19c0: 65 73 29 0a 09 09 72 65 73 29 29 29 29 29 29 0a es)...res)))))).
19d0: 20 20 0a 28 64 65 66 69 6e 65 20 28 63 61 6c 63 .(define (calc
19e0: 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c -allow-system al
19f0: 6c 6f 77 2d 73 79 73 74 65 6d 20 73 65 63 74 69 low-system secti
1a00: 6f 6e 20 73 65 63 74 69 6f 6e 73 29 0a 20 20 28 on sections). (
1a10: 69 66 20 73 65 63 74 69 6f 6e 73 0a 20 20 20 20 if sections.
1a20: 20 20 28 61 6e 64 20 28 6f 72 20 28 65 71 75 61 (and (or (equa
1a30: 6c 3f 20 22 64 65 66 61 75 6c 74 22 20 73 65 63 l? "default" sec
1a40: 74 69 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 6d tion).. (m
1a50: 65 6d 62 65 72 20 73 65 63 74 69 6f 6e 20 73 65 ember section se
1a60: 63 74 69 6f 6e 73 29 29 0a 09 20 20 20 61 6c 6c ctions)).. all
1a70: 6f 77 2d 73 79 73 74 65 6d 29 20 3b 3b 20 61 63 ow-system) ;; ac
1a80: 63 6f 75 6e 74 20 66 6f 72 20 73 65 63 74 69 6f count for sectio
1a90: 6e 73 20 61 6e 64 20 72 65 74 75 72 6e 20 61 6c ns and return al
1aa0: 6c 6f 77 2d 73 79 73 74 65 6d 20 61 73 20 69 74 low-system as it
1ab0: 20 6d 69 67 68 74 20 62 65 20 61 20 73 79 6d 62 might be a symb
1ac0: 6f 6c 20 73 75 63 68 20 61 73 20 72 65 74 75 72 ol such as retur
1ad0: 6e 2d 73 74 72 69 6e 67 73 0a 20 20 20 20 20 20 n-strings.
1ae0: 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 29 29 0a 20 allow-system)).
1af0: 20 20 20 0a 3b 3b 20 72 65 61 64 20 61 20 63 6f .;; read a co
1b00: 6e 66 69 67 20 66 69 6c 65 2c 20 72 65 74 75 72 nfig file, retur
1b10: 6e 73 20 68 61 73 68 20 74 61 62 6c 65 20 6f 66 ns hash table of
1b20: 20 61 6c 69 73 74 73 0a 0a 3b 3b 20 72 65 61 64 alists..;; read
1b30: 20 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 2c 20 a config file,
1b40: 72 65 74 75 72 6e 73 20 68 61 73 68 20 74 61 62 returns hash tab
1b50: 6c 65 20 6f 66 20 61 6c 69 73 74 73 0a 3b 3b 20 le of alists.;;
1b60: 61 64 64 73 20 74 6f 20 68 74 20 69 66 20 67 69 adds to ht if gi
1b70: 76 65 6e 20 28 6d 75 73 74 20 62 65 20 23 66 20 ven (must be #f
1b80: 6f 74 68 65 72 77 69 73 65 29 0a 3b 3b 20 65 6e otherwise).;; en
1b90: 76 69 6f 6e 2d 70 61 74 74 20 69 73 20 61 20 72 vion-patt is a r
1ba0: 65 67 65 78 20 73 70 65 63 20 74 68 61 74 20 69 egex spec that i
1bb0: 64 65 6e 74 69 66 69 65 73 20 73 65 63 74 69 6f dentifies sectio
1bc0: 6e 73 20 74 68 61 74 20 77 69 6c 6c 20 62 65 20 ns that will be
1bd0: 65 76 61 6c 27 64 0a 3b 3b 20 69 6e 20 74 68 65 eval'd.;; in the
1be0: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 6f 6e 20 environment on
1bf0: 74 68 65 20 66 6c 79 0a 3b 3b 20 73 65 63 74 69 the fly.;; secti
1c00: 6f 6e 73 3a 20 23 66 20 3d 3e 20 67 65 74 20 61 ons: #f => get a
1c10: 6c 6c 2c 20 65 6c 73 65 20 6c 69 73 74 20 6f 66 ll, else list of
1c20: 20 73 65 63 74 69 6f 6e 73 20 74 6f 20 67 61 74 sections to gat
1c30: 68 65 72 0a 3b 3b 20 70 6f 73 74 2d 73 65 63 74 her.;; post-sect
1c40: 69 6f 6e 2d 70 72 6f 63 73 20 61 6c 69 73 74 20 ion-procs alist
1c50: 6f 66 20 73 65 63 74 69 6f 6e 2d 70 61 74 74 65 of section-patte
1c60: 72 6e 20 3d 3e 20 70 72 6f 63 2c 20 77 68 65 72 rn => proc, wher
1c70: 65 3a 20 28 70 72 6f 63 20 73 65 63 74 69 6f 6e e: (proc section
1c80: 2d 6e 61 6d 65 20 6e 65 78 74 2d 73 65 63 74 69 -name next-secti
1c90: 6f 6e 2d 6e 61 6d 65 20 68 74 20 63 75 72 72 2d on-name ht curr-
1ca0: 70 61 74 68 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 path).;;.(define
1cb0: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 70 61 (read-config pa
1cc0: 74 68 20 68 74 20 61 6c 6c 6f 77 2d 73 79 73 74 th ht allow-syst
1cd0: 65 6d 20 23 21 6b 65 79 20 28 65 6e 76 69 72 6f em #!key (enviro
1ce0: 6e 2d 70 61 74 74 20 23 66 29 28 63 75 72 72 2d n-patt #f)(curr-
1cf0: 73 65 63 74 69 6f 6e 20 23 66 29 28 73 65 63 74 section #f)(sect
1d00: 69 6f 6e 73 20 23 66 29 28 73 65 74 74 69 6e 67 ions #f)(setting
1d10: 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
1d20: 6c 65 29 29 28 6b 65 65 70 2d 66 69 6c 65 6e 61 le))(keep-filena
1d30: 6d 65 73 20 23 66 29 28 70 6f 73 74 2d 73 65 63 mes #f)(post-sec
1d40: 74 69 6f 6e 2d 70 72 6f 63 73 20 27 28 29 29 29 tion-procs '()))
1d50: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
1d60: 69 6e 66 6f 20 35 20 2a 64 65 66 61 75 6c 74 2d info 5 *default-
1d70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 61 64 2d log-port* "read-
1d80: 63 6f 6e 66 69 67 20 22 20 70 61 74 68 20 22 20 config " path "
1d90: 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 22 20 61 allow-system " a
1da0: 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 22 20 65 6e llow-system " en
1db0: 76 69 72 6f 6e 2d 70 61 74 74 20 22 20 65 6e 76 viron-patt " env
1dc0: 69 72 6f 6e 2d 70 61 74 74 20 22 20 63 75 72 72 iron-patt " curr
1dd0: 2d 73 65 63 74 69 6f 6e 3a 20 22 20 63 75 72 72 -section: " curr
1de0: 2d 73 65 63 74 69 6f 6e 20 22 20 73 65 63 74 69 -section " secti
1df0: 6f 6e 73 3a 20 22 20 73 65 63 74 69 6f 6e 73 20 ons: " sections
1e00: 22 20 70 77 64 3a 20 22 20 28 63 75 72 72 65 6e " pwd: " (curren
1e10: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 20 20 t-directory)).
1e20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 39 20 2a (debug:print 9 *
1e30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1e40: 2a 20 22 53 54 41 52 54 3a 20 22 20 70 61 74 68 * "START: " path
1e50: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 ). (if (not (fi
1e60: 6c 65 2d 65 78 69 73 74 73 3f 20 70 61 74 68 29 le-exists? path)
1e70: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a ). (begin .
1e80: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
1e90: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
1ea0: 67 2d 70 6f 72 74 2a 20 22 72 65 61 64 2d 63 6f g-port* "read-co
1eb0: 6e 66 69 67 20 2d 20 66 69 6c 65 20 6e 6f 74 20 nfig - file not
1ec0: 66 6f 75 6e 64 20 22 20 70 61 74 68 20 22 20 63 found " path " c
1ed0: 75 72 72 65 6e 74 20 70 61 74 68 3a 20 22 20 28 urrent path: " (
1ee0: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
1ef0: 79 29 29 0a 09 3b 3b 20 57 41 52 4e 49 4e 47 3a y))..;; WARNING:
1f00: 20 54 68 69 73 20 69 73 20 61 20 72 69 73 6b 79 This is a risky
1f10: 20 63 68 61 6e 67 65 20 62 75 74 20 72 65 61 6c change but real
1f20: 6c 79 2c 20 77 65 20 73 68 6f 75 6c 64 20 6e 6f ly, we should no
1f30: 74 20 72 65 74 75 72 6e 20 61 6e 20 65 6d 70 74 t return an empt
1f40: 79 20 68 61 73 68 20 74 61 62 6c 65 20 69 66 20 y hash table if
1f50: 6e 6f 20 66 69 6c 65 20 72 65 61 64 3f 0a 09 23 no file read?..#
1f60: 66 29 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 68 f) ;; (if (not h
1f70: 74 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 t)(make-hash-tab
1f80: 6c 65 29 20 68 74 29 29 0a 20 20 20 20 20 20 28 le) ht)). (
1f90: 6c 65 74 20 28 28 69 6e 70 20 20 20 20 20 20 20 let ((inp
1fa0: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c (open-input-fil
1fb0: 65 20 70 61 74 68 29 29 0a 09 20 20 20 20 28 72 e path)).. (r
1fc0: 65 73 20 20 20 20 20 20 20 20 28 69 66 20 28 6e es (if (n
1fd0: 6f 74 20 68 74 29 28 6d 61 6b 65 2d 68 61 73 68 ot ht)(make-hash
1fe0: 2d 74 61 62 6c 65 29 20 68 74 29 29 0a 09 20 20 -table) ht))..
1ff0: 20 20 28 6d 65 74 61 70 61 74 68 20 20 20 28 69 (metapath (i
2000: 66 20 28 6f 72 20 28 64 65 62 75 67 3a 64 65 62 f (or (debug:deb
2010: 75 67 2d 6d 6f 64 65 20 39 29 0a 09 09 09 09 6b ug-mode 9).....k
2020: 65 65 70 2d 66 69 6c 65 6e 61 6d 65 73 29 0a 09 eep-filenames)..
2030: 09 09 20 20 20 20 70 61 74 68 20 23 66 29 29 29 .. path #f)))
2040: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e ..(let loop ((in
2050: 6c 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 l
2060: 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 6c 69 (configf:read-li
2070: 6e 65 20 69 6e 70 20 72 65 73 20 28 63 61 6c 63 ne inp res (calc
2080: 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c -allow-system al
2090: 6c 6f 77 2d 73 79 73 74 65 6d 20 63 75 72 72 2d low-system curr-
20a0: 73 65 63 74 69 6f 6e 20 73 65 63 74 69 6f 6e 73 section sections
20b0: 29 20 73 65 74 74 69 6e 67 73 29 29 20 3b 3b 20 ) settings)) ;;
20c0: 28 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 29 29 (read-line inp))
20d0: 0a 09 09 20 20 20 28 63 75 72 72 2d 73 65 63 74 ... (curr-sect
20e0: 69 6f 6e 2d 6e 61 6d 65 20 28 69 66 20 63 75 72 ion-name (if cur
20f0: 72 2d 73 65 63 74 69 6f 6e 20 63 75 72 72 2d 73 r-section curr-s
2100: 65 63 74 69 6f 6e 20 22 64 65 66 61 75 6c 74 22 ection "default"
2110: 29 29 0a 09 09 20 20 20 28 76 61 72 2d 66 6c 61 ))... (var-fla
2120: 67 20 23 66 29 3b 3b 20 74 75 72 6e 20 6f 6e 20 g #f);; turn on
2130: 66 6f 72 20 6b 65 79 2d 76 61 72 2d 70 72 20 61 for key-var-pr a
2140: 6e 64 20 63 6f 6e 74 2d 6c 6e 2d 72 78 2c 20 74 nd cont-ln-rx, t
2150: 75 72 6e 20 6f 66 66 20 65 6c 73 65 77 68 65 72 urn off elsewher
2160: 65 0a 09 09 20 20 20 28 6c 65 61 64 20 20 20 20 e... (lead
2170: 20 23 66 29 29 0a 09 20 20 28 64 65 62 75 67 3a #f)).. (debug:
2180: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
2190: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
21a0: 22 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 "curr-section-na
21b0: 6d 65 3a 20 22 20 63 75 72 72 2d 73 65 63 74 69 me: " curr-secti
21c0: 6f 6e 2d 6e 61 6d 65 20 22 20 76 61 72 2d 66 6c on-name " var-fl
21d0: 61 67 3a 20 22 20 76 61 72 2d 66 6c 61 67 20 22 ag: " var-flag "
21e0: 5c 6e 20 20 20 69 6e 6c 3a 20 5c 22 22 20 69 6e \n inl: \"" in
21f0: 6c 20 22 5c 22 22 29 0a 09 20 20 28 69 66 20 28 l "\"").. (if (
2200: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 eof-object? inl)
2210: 20 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
2220: 09 09 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 ..(close-input-p
2230: 6f 72 74 20 69 6e 70 29 0a 09 09 28 68 61 73 68 ort inp)...(hash
2240: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 72 -table-delete! r
2250: 65 73 20 22 22 29 20 3b 3b 20 77 65 20 61 72 65 es "") ;; we are
2260: 20 75 73 69 6e 67 20 22 22 20 61 73 20 61 20 64 using "" as a d
2270: 75 6d 70 69 6e 67 20 67 72 6f 75 6e 64 20 61 6e umping ground an
2280: 64 20 6d 75 73 74 20 72 65 6d 6f 76 65 20 69 74 d must remove it
2290: 20 62 65 66 6f 72 65 20 72 65 74 75 72 6e 69 6e before returnin
22a0: 67 20 74 68 65 20 68 74 0a 09 09 28 64 65 62 75 g the ht...(debu
22b0: 67 3a 70 72 69 6e 74 20 39 20 2a 64 65 66 61 75 g:print 9 *defau
22c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 4e lt-log-port* "EN
22d0: 44 3a 20 22 20 70 61 74 68 29 0a 09 09 72 65 73 D: " path)...res
22e0: 29 0a 09 20 20 20 20 20 20 28 72 65 67 65 78 2d ).. (regex-
22f0: 63 61 73 65 20 0a 09 20 20 20 20 20 20 20 69 6e case .. in
2300: 6c 20 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 66 l .. (conf
2310: 69 67 66 3a 63 6f 6d 6d 65 6e 74 2d 72 78 20 5f igf:comment-rx _
2320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2330: 20 20 28 6c 6f 6f 70 20 28 63 6f 6e 66 69 67 66 (loop (configf
2340: 3a 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 20 72 :read-line inp r
2350: 65 73 20 28 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 es (calc-allow-s
2360: 79 73 74 65 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 ystem allow-syst
2370: 65 6d 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d em curr-section-
2380: 6e 61 6d 65 20 73 65 63 74 69 6f 6e 73 29 20 73 name sections) s
2390: 65 74 74 69 6e 67 73 29 20 63 75 72 72 2d 73 65 ettings) curr-se
23a0: 63 74 69 6f 6e 2d 6e 61 6d 65 20 23 66 20 23 66 ction-name #f #f
23b0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 66 )).. (conf
23c0: 69 67 66 3a 62 6c 61 6e 6b 2d 6c 2d 72 78 20 5f igf:blank-l-rx _
23d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23e0: 20 20 28 6c 6f 6f 70 20 28 63 6f 6e 66 69 67 66 (loop (configf
23f0: 3a 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 20 72 :read-line inp r
2400: 65 73 20 28 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 es (calc-allow-s
2410: 79 73 74 65 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 ystem allow-syst
2420: 65 6d 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d em curr-section-
2430: 6e 61 6d 65 20 73 65 63 74 69 6f 6e 73 29 20 73 name sections) s
2440: 65 74 74 69 6e 67 73 29 20 63 75 72 72 2d 73 65 ettings) curr-se
2450: 63 74 69 6f 6e 2d 6e 61 6d 65 20 23 66 20 23 66 ction-name #f #f
2460: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 66 )).. (conf
2470: 69 67 66 3a 73 65 74 74 69 6e 67 73 20 20 20 28 igf:settings (
2480: 20 78 20 73 65 74 74 69 6e 67 20 76 61 6c 20 20 x setting val
2490: 29 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 ) (begin........
24a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
24b0: 20 73 65 74 74 69 6e 67 73 20 73 65 74 74 69 6e settings settin
24c0: 67 20 76 61 6c 29 0a 09 09 09 09 09 09 09 28 6c g val)........(l
24d0: 6f 6f 70 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 oop (configf:rea
24e0: 64 2d 6c 69 6e 65 20 69 6e 70 20 72 65 73 20 28 d-line inp res (
24f0: 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 calc-allow-syste
2500: 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 63 m allow-system c
2510: 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 urr-section-name
2520: 20 73 65 63 74 69 6f 6e 73 29 20 73 65 74 74 69 sections) setti
2530: 6e 67 73 29 20 63 75 72 72 2d 73 65 63 74 69 6f ngs) curr-sectio
2540: 6e 2d 6e 61 6d 65 20 23 66 20 23 66 29 29 29 0a n-name #f #f))).
2550: 09 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 . (configf
2560: 3a 69 6e 63 6c 75 64 65 2d 72 78 20 28 20 78 20 :include-rx ( x
2570: 69 6e 63 6c 75 64 65 2d 66 69 6c 65 20 29 20 28 include-file ) (
2580: 6c 65 74 2a 20 28 28 63 75 72 72 2d 63 6f 6e 66 let* ((curr-conf
2590: 2d 64 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 -dir (pathname-d
25a0: 69 72 65 63 74 6f 72 79 20 70 61 74 68 29 29 0a irectory path)).
25b0: 09 09 09 09 09 09 09 20 20 20 20 20 28 66 75 6c ....... (ful
25c0: 6c 2d 63 6f 6e 66 20 20 20 20 20 28 69 66 20 28 l-conf (if (
25d0: 61 62 73 6f 6c 75 74 65 2d 70 61 74 68 6e 61 6d absolute-pathnam
25e0: 65 3f 20 69 6e 63 6c 75 64 65 2d 66 69 6c 65 29 e? include-file)
25f0: 0a 09 09 09 09 09 09 09 09 09 09 69 6e 63 6c 75 ...........inclu
2600: 64 65 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 09 de-file.........
2610: 09 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 ..(common:nice-p
2620: 61 74 68 20 0a 09 09 09 09 09 09 09 09 09 09 20 ath ...........
2630: 28 63 6f 6e 63 20 28 69 66 20 63 75 72 72 2d 63 (conc (if curr-c
2640: 6f 6e 66 2d 64 69 72 0a 09 09 09 09 09 09 09 09 onf-dir.........
2650: 09 09 09 20 20 20 63 75 72 72 2d 63 6f 6e 66 2d ... curr-conf-
2660: 64 69 72 0a 09 09 09 09 09 09 09 09 09 09 09 20 dir............
2670: 20 20 22 2e 22 29 0a 09 09 09 09 09 09 09 09 09 ".")..........
2680: 09 20 20 20 20 20 20 20 22 2f 22 20 69 6e 63 6c . "/" incl
2690: 75 64 65 2d 66 69 6c 65 29 29 29 29 29 0a 09 09 ude-file)))))...
26a0: 09 09 09 09 09 28 69 66 20 28 66 69 6c 65 2d 65 .....(if (file-e
26b0: 78 69 73 74 73 3f 20 66 75 6c 6c 2d 63 6f 6e 66 xists? full-conf
26c0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 28 62 65 )........ (be
26d0: 67 69 6e 0a 09 09 09 09 09 09 09 20 20 20 20 20 gin........
26e0: 20 3b 3b 20 28 70 75 73 68 2d 64 69 72 65 63 74 ;; (push-direct
26f0: 6f 72 79 20 63 6f 6e 66 2d 64 69 72 29 0a 09 09 ory conf-dir)...
2700: 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
2710: 67 3a 70 72 69 6e 74 20 39 20 2a 64 65 66 61 75 g:print 9 *defau
2720: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e lt-log-port* "In
2730: 63 6c 75 64 69 6e 67 3a 20 22 20 66 75 6c 6c 2d cluding: " full-
2740: 63 6f 6e 66 29 0a 09 09 09 09 09 09 09 20 20 20 conf)........
2750: 20 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 (read-config
2760: 66 75 6c 6c 2d 63 6f 6e 66 20 72 65 73 20 61 6c full-conf res al
2770: 6c 6f 77 2d 73 79 73 74 65 6d 20 65 6e 76 69 72 low-system envir
2780: 6f 6e 2d 70 61 74 74 3a 20 65 6e 76 69 72 6f 6e on-patt: environ
2790: 2d 70 61 74 74 20 63 75 72 72 2d 73 65 63 74 69 -patt curr-secti
27a0: 6f 6e 3a 20 63 75 72 72 2d 73 65 63 74 69 6f 6e on: curr-section
27b0: 2d 6e 61 6d 65 20 73 65 63 74 69 6f 6e 73 3a 20 -name sections:
27c0: 73 65 63 74 69 6f 6e 73 20 73 65 74 74 69 6e 67 sections setting
27d0: 73 3a 20 73 65 74 74 69 6e 67 73 20 6b 65 65 70 s: settings keep
27e0: 2d 66 69 6c 65 6e 61 6d 65 73 3a 20 6b 65 65 70 -filenames: keep
27f0: 2d 66 69 6c 65 6e 61 6d 65 73 29 0a 09 09 09 09 -filenames).....
2800: 09 09 09 20 20 20 20 20 20 3b 3b 20 28 70 6f 70 ... ;; (pop
2810: 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 09 09 09 -directory).....
2820: 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
2830: 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 6c 69 6e configf:read-lin
2840: 65 20 69 6e 70 20 72 65 73 20 28 63 61 6c 63 2d e inp res (calc-
2850: 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c 6c allow-system all
2860: 6f 77 2d 73 79 73 74 65 6d 20 63 75 72 72 2d 73 ow-system curr-s
2870: 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 73 65 63 74 ection-name sect
2880: 69 6f 6e 73 29 20 73 65 74 74 69 6e 67 73 29 20 ions) settings)
2890: 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d curr-section-nam
28a0: 65 20 23 66 20 23 66 29 29 0a 09 09 09 09 09 09 e #f #f)).......
28b0: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 . (begin.....
28c0: 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
28d0: 70 72 69 6e 74 20 27 28 32 20 39 29 20 23 66 20 print '(2 9) #f
28e0: 22 49 4e 46 4f 3a 20 69 6e 63 6c 75 64 65 20 66 "INFO: include f
28f0: 69 6c 65 20 22 20 69 6e 63 6c 75 64 65 2d 66 69 ile " include-fi
2900: 6c 65 20 22 20 6e 6f 74 20 66 6f 75 6e 64 20 28 le " not found (
2910: 63 61 6c 6c 65 64 20 66 72 6f 6d 20 22 20 70 61 called from " pa
2920: 74 68 20 22 29 22 29 0a 09 09 09 09 09 09 09 20 th ")")........
2930: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2940: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
2950: 2d 70 6f 72 74 2a 20 22 20 20 20 20 20 20 20 20 -port* "
2960: 22 20 66 75 6c 6c 2d 63 6f 6e 66 29 0a 09 09 09 " full-conf)....
2970: 09 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 .... (loop
2980: 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 6c 69 (configf:read-li
2990: 6e 65 20 69 6e 70 20 72 65 73 20 28 63 61 6c 63 ne inp res (calc
29a0: 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c -allow-system al
29b0: 6c 6f 77 2d 73 79 73 74 65 6d 20 63 75 72 72 2d low-system curr-
29c0: 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 73 65 63 section-name sec
29d0: 74 69 6f 6e 73 29 20 73 65 74 74 69 6e 67 73 29 tions) settings)
29e0: 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 curr-section-na
29f0: 6d 65 20 23 66 20 23 66 29 29 29 29 29 0a 09 20 me #f #f)))))..
2a00: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 73 (configf:s
2a10: 65 63 74 69 6f 6e 2d 72 78 20 28 20 78 20 73 65 ection-rx ( x se
2a20: 63 74 69 6f 6e 2d 6e 61 6d 65 20 29 20 28 62 65 ction-name ) (be
2a30: 67 69 6e 0a 09 09 09 09 09 09 09 3b 3b 20 63 61 gin........;; ca
2a40: 6c 6c 20 70 6f 73 74 2d 73 65 63 74 69 6f 6e 2d ll post-section-
2a50: 70 72 6f 63 73 0a 09 09 09 09 09 09 09 28 66 6f procs........(fo
2a60: 72 2d 65 61 63 68 20 0a 09 09 09 09 09 09 09 20 r-each ........
2a70: 28 6c 61 6d 62 64 61 20 28 64 61 74 29 0a 09 09 (lambda (dat)...
2a80: 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 70 ..... (let ((p
2a90: 61 74 74 20 28 63 61 72 20 64 61 74 29 29 0a 09 att (car dat))..
2aa0: 09 09 09 09 09 09 09 20 28 70 72 6f 63 20 28 63 ....... (proc (c
2ab0: 64 72 20 64 61 74 29 29 29 0a 09 09 09 09 09 09 dr dat))).......
2ac0: 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e . (if (strin
2ad0: 67 2d 6d 61 74 63 68 20 70 61 74 74 20 63 75 72 g-match patt cur
2ae0: 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 29 0a r-section-name).
2af0: 09 09 09 09 09 09 09 09 20 28 70 72 6f 63 20 63 ........ (proc c
2b00: 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 urr-section-name
2b10: 20 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 72 65 section-name re
2b20: 73 20 70 61 74 68 29 29 29 29 0a 09 09 09 09 09 s path))))......
2b30: 09 09 20 70 6f 73 74 2d 73 65 63 74 69 6f 6e 2d .. post-section-
2b40: 70 72 6f 63 73 29 0a 09 09 09 09 09 09 09 28 6c procs)........(l
2b50: 6f 6f 70 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 oop (configf:rea
2b60: 64 2d 6c 69 6e 65 20 69 6e 70 20 72 65 73 20 28 d-line inp res (
2b70: 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 calc-allow-syste
2b80: 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 63 m allow-system c
2b90: 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 urr-section-name
2ba0: 20 73 65 63 74 69 6f 6e 73 29 20 73 65 74 74 69 sections) setti
2bb0: 6e 67 73 29 0a 09 09 09 09 09 09 09 20 20 20 20 ngs)........
2bc0: 20 20 3b 3b 20 69 66 20 77 65 20 68 61 76 65 20 ;; if we have
2bd0: 74 68 65 20 73 65 63 74 69 6f 6e 73 20 6c 69 73 the sections lis
2be0: 74 20 74 68 65 6e 20 66 6f 72 63 65 20 61 6c 6c t then force all
2bf0: 20 73 65 74 74 69 6e 67 73 20 69 6e 74 6f 20 22 settings into "
2c00: 22 20 61 6e 64 20 64 65 6c 65 74 65 20 69 74 20 " and delete it
2c10: 6c 61 74 65 72 3f 0a 09 09 09 09 09 09 09 20 20 later?........
2c20: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
2c30: 20 73 65 63 74 69 6f 6e 73 29 20 0a 09 09 09 09 sections) .....
2c40: 09 09 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 .... (membe
2c50: 72 20 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 73 r section-name s
2c60: 65 63 74 69 6f 6e 73 29 29 0a 09 09 09 09 09 09 ections)).......
2c70: 09 09 20 20 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 .. section-name
2c80: 20 22 22 29 20 3b 3b 20 73 74 69 63 6b 20 65 76 "") ;; stick ev
2c90: 65 72 79 74 68 69 6e 67 20 69 6e 74 6f 20 22 22 erything into ""
2ca0: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 23 66 ........ #f
2cb0: 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 20 28 #f))).. (
2cc0: 63 6f 6e 66 69 67 66 3a 6b 65 79 2d 73 79 73 2d configf:key-sys-
2cd0: 70 72 20 28 20 78 20 6b 65 79 20 63 6d 64 20 20 pr ( x key cmd
2ce0: 20 20 20 20 29 20 28 69 66 20 28 63 61 6c 63 2d ) (if (calc-
2cf0: 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c 6c allow-system all
2d00: 6f 77 2d 73 79 73 74 65 6d 20 63 75 72 72 2d 73 ow-system curr-s
2d10: 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 73 65 63 74 ection-name sect
2d20: 69 6f 6e 73 29 0a 09 09 09 09 09 09 09 20 20 28 ions)........ (
2d30: 6c 65 74 20 28 28 61 6c 69 73 74 20 20 20 20 28 let ((alist (
2d40: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2d50: 65 66 61 75 6c 74 20 72 65 73 20 63 75 72 72 2d efault res curr-
2d60: 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 27 28 29 section-name '()
2d70: 29 29 0a 09 09 09 09 09 09 09 09 28 76 61 6c 2d )).........(val-
2d80: 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 0a proc (lambda ().
2d90: 09 09 09 09 09 09 09 09 09 20 20 20 20 28 6c 65 ......... (le
2da0: 74 2a 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 t* ((start-time
2db0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2dc0: 29 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 20 ))...........
2dd0: 28 63 6d 64 72 65 73 20 20 20 20 20 28 70 72 6f (cmdres (pro
2de0: 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 cess:cmd-run->li
2df0: 73 74 20 63 6d 64 29 29 0a 09 09 09 09 09 09 09 st cmd))........
2e00: 09 09 09 20 20 20 28 64 65 6c 74 61 20 20 20 20 ... (delta
2e10: 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 (- (current-se
2e20: 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d conds) start-tim
2e30: 65 29 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 e))...........
2e40: 20 28 73 74 61 74 75 73 20 20 20 20 20 28 63 61 (status (ca
2e50: 64 72 20 63 6d 64 72 65 73 29 29 0a 09 09 09 09 dr cmdres)).....
2e60: 09 09 09 09 09 09 20 20 20 28 72 65 73 20 20 20 ...... (res
2e70: 20 20 20 20 20 28 63 61 72 20 20 63 6d 64 72 65 (car cmdre
2e80: 73 29 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 s)))..........
2e90: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2ea0: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
2eb0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 22 20 69 6e -log-port* "" in
2ec0: 6c 20 22 5c 6e 20 3d 3e 20 22 20 28 73 74 72 69 l "\n => " (stri
2ed0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 ng-intersperse r
2ee0: 65 73 20 22 5c 6e 22 29 29 0a 09 09 09 09 09 09 es "\n")).......
2ef0: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ... (if (no
2f00: 74 20 28 65 71 3f 20 73 74 61 74 75 73 20 30 29 t (eq? status 0)
2f10: 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 28 62 )........... (b
2f20: 65 67 69 6e 0a 09 09 09 09 09 09 09 09 09 09 20 egin...........
2f30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2f40: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
2f50: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 72 6f 62 -log-port* "prob
2f60: 6c 65 6d 20 77 69 74 68 20 22 20 69 6e 6c 20 22 lem with " inl "
2f70: 2c 20 72 65 74 75 72 6e 20 63 6f 64 65 20 22 20 , return code "
2f80: 73 74 61 74 75 73 0a 09 09 09 09 09 09 09 09 09 status..........
2f90: 09 09 09 20 22 20 6f 75 74 70 75 74 3a 20 22 20 ... " output: "
2fa0: 63 6d 64 72 65 73 29 29 29 0a 09 09 09 09 09 09 cmdres))).......
2fb0: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ... (if (>
2fc0: 64 65 6c 74 61 20 32 29 0a 09 09 09 09 09 09 09 delta 2)........
2fd0: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
2fe0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
2ff0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 6f 72 t-log-port* "for
3000: 20 6c 69 6e 65 20 5c 22 22 20 69 6e 6c 20 22 5c line \"" inl "\
3010: 22 5c 6e 20 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 "\n command: "
3020: 63 6d 64 20 22 20 74 6f 6f 6b 20 22 20 64 65 6c cmd " took " del
3030: 74 61 20 22 20 73 65 63 6f 6e 64 73 20 74 6f 20 ta " seconds to
3040: 72 75 6e 20 77 69 74 68 20 6f 75 74 70 75 74 3a run with output:
3050: 5c 6e 20 20 20 22 20 72 65 73 29 0a 09 09 09 09 \n " res).....
3060: 09 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 ...... (debug:p
3070: 72 69 6e 74 2d 69 6e 66 6f 20 39 20 2a 64 65 66 rint-info 9 *def
3080: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3090: 66 6f 72 20 6c 69 6e 65 20 5c 22 22 20 69 6e 6c for line \"" inl
30a0: 20 22 5c 22 5c 6e 20 20 63 6f 6d 6d 61 6e 64 3a "\"\n command:
30b0: 20 22 20 63 6d 64 20 22 20 74 6f 6f 6b 20 22 20 " cmd " took "
30c0: 64 65 6c 74 61 20 22 20 73 65 63 6f 6e 64 73 20 delta " seconds
30d0: 74 6f 20 72 75 6e 20 77 69 74 68 20 6f 75 74 70 to run with outp
30e0: 75 74 3a 5c 6e 20 20 20 22 20 72 65 73 29 29 0a ut:\n " res)).
30f0: 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 28 ......... (
3100: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 73 29 0a 09 if (null? res)..
3110: 09 09 09 09 09 09 09 09 09 20 20 22 22 0a 09 09 ......... ""...
3120: 09 09 09 09 09 09 09 09 20 20 28 73 74 72 69 6e ........ (strin
3130: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 65 g-intersperse re
3140: 73 20 22 20 22 29 29 29 29 29 29 0a 09 09 09 09 s " ")))))).....
3150: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
3160: 6c 65 2d 73 65 74 21 20 72 65 73 20 63 75 72 72 le-set! res curr
3170: 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 0a 09 -section-name ..
3180: 09 09 09 09 09 09 09 09 20 20 20 20 20 28 63 6f ........ (co
3190: 6e 66 69 67 3a 61 73 73 6f 63 2d 73 61 66 65 2d nfig:assoc-safe-
31a0: 61 64 64 20 61 6c 69 73 74 0a 09 09 09 09 09 09 add alist.......
31b0: 09 09 09 20 20 20 09 09 09 20 20 20 20 6b 65 79 ... ... key
31c0: 20 0a 09 09 09 09 09 09 09 09 09 09 09 09 20 20 .............
31d0: 20 20 28 63 61 73 65 20 28 63 61 6c 63 2d 61 6c (case (calc-al
31e0: 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c 6c 6f 77 low-system allow
31f0: 2d 73 79 73 74 65 6d 20 63 75 72 72 2d 73 65 63 -system curr-sec
3200: 74 69 6f 6e 2d 6e 61 6d 65 20 73 65 63 74 69 6f tion-name sectio
3210: 6e 73 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 ns).............
3220: 20 20 20 20 20 20 28 28 72 65 74 75 72 6e 2d 70 ((return-p
3230: 72 6f 63 73 29 20 76 61 6c 2d 70 72 6f 63 29 0a rocs) val-proc).
3240: 09 09 09 09 09 09 09 09 09 09 09 09 20 20 20 20 ............
3250: 20 20 28 28 72 65 74 75 72 6e 2d 73 74 72 69 6e ((return-strin
3260: 67 29 20 63 6d 64 29 0a 09 09 09 09 09 09 09 09 g) cmd).........
3270: 09 09 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 .... (else
3280: 28 76 61 6c 2d 70 72 6f 63 29 29 29 0a 09 09 09 (val-proc)))....
3290: 09 09 09 09 09 09 09 09 09 20 20 20 20 6d 65 74 ......... met
32a0: 61 64 61 74 61 3a 20 6d 65 74 61 70 61 74 68 29 adata: metapath)
32b0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 28 6c 6f )........ (lo
32c0: 6f 70 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 op (configf:read
32d0: 2d 6c 69 6e 65 20 69 6e 70 20 72 65 73 20 28 63 -line inp res (c
32e0: 61 6c 63 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 6d alc-allow-system
32f0: 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 63 75 allow-system cu
3300: 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 rr-section-name
3310: 73 65 63 74 69 6f 6e 73 29 20 73 65 74 74 69 6e sections) settin
3320: 67 73 29 20 63 75 72 72 2d 73 65 63 74 69 6f 6e gs) curr-section
3330: 2d 6e 61 6d 65 20 23 66 20 23 66 29 29 0a 09 09 -name #f #f))...
3340: 09 09 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 6f ..... (loop (co
3350: 6e 66 69 67 66 3a 72 65 61 64 2d 6c 69 6e 65 20 nfigf:read-line
3360: 69 6e 70 20 72 65 73 20 28 63 61 6c 63 2d 61 6c inp res (calc-al
3370: 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c 6c 6f 77 low-system allow
3380: 2d 73 79 73 74 65 6d 20 63 75 72 72 2d 73 65 63 -system curr-sec
3390: 74 69 6f 6e 2d 6e 61 6d 65 20 73 65 63 74 69 6f tion-name sectio
33a0: 6e 73 29 20 73 65 74 74 69 6e 67 73 29 20 63 75 ns) settings) cu
33b0: 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 rr-section-name
33c0: 23 66 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 #f #f)))..
33d0: 20 28 63 6f 6e 66 69 67 66 3a 6b 65 79 2d 6e 6f (configf:key-no
33e0: 2d 76 61 6c 20 28 20 78 20 6b 65 79 20 76 61 6c -val ( x key val
33f0: 29 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 ) (le
3400: 74 2a 20 28 28 61 6c 69 73 74 20 20 20 28 68 61 t* ((alist (ha
3410: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3420: 61 75 6c 74 20 72 65 73 20 63 75 72 72 2d 73 65 ault res curr-se
3430: 63 74 69 6f 6e 2d 6e 61 6d 65 20 27 28 29 29 29 ction-name '()))
3440: 0a 09 09 09 09 09 09 09 09 20 20 28 66 76 61 6c ......... (fval
3450: 20 20 20 20 28 6f 72 20 28 69 66 20 28 73 74 72 (or (if (str
3460: 69 6e 67 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 ing? val) val #f
3470: 29 20 22 22 29 29 29 20 3b 3b 20 66 76 61 6c 20 ) ""))) ;; fval
3480: 73 68 6f 75 6c 64 20 62 65 20 65 69 74 68 65 72 should be either
3490: 20 22 22 20 6f 72 20 22 20 22 20 28 6f 6e 65 20 "" or " " (one
34a0: 6f 72 20 6d 6f 72 65 20 73 70 61 63 65 73 29 0a or more spaces).
34b0: 09 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
34c0: 75 67 3a 70 72 69 6e 74 20 31 30 20 2a 64 65 66 ug:print 10 *def
34d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
34e0: 20 20 20 73 65 74 74 69 6e 67 3a 20 5b 22 20 63 setting: [" c
34f0: 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 urr-section-name
3500: 20 22 5d 20 22 20 6b 65 79 20 22 20 3d 20 23 74 "] " key " = #t
3510: 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 ")........ (
3520: 73 61 66 65 2d 73 65 74 65 6e 76 20 6b 65 79 20 safe-setenv key
3530: 66 76 61 6c 29 0a 09 09 09 09 09 09 09 20 20 20 fval)........
3540: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
3550: 74 21 20 72 65 73 20 63 75 72 72 2d 73 65 63 74 t! res curr-sect
3560: 69 6f 6e 2d 6e 61 6d 65 20 0a 09 09 09 09 09 09 ion-name .......
3570: 09 09 09 20 20 20 20 20 20 28 63 6f 6e 66 69 67 ... (config
3580: 3a 61 73 73 6f 63 2d 73 61 66 65 2d 61 64 64 20 :assoc-safe-add
3590: 61 6c 69 73 74 20 6b 65 79 20 66 76 61 6c 20 6d alist key fval m
35a0: 65 74 61 64 61 74 61 3a 20 6d 65 74 61 70 61 74 etadata: metapat
35b0: 68 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 h))........
35c0: 28 6c 6f 6f 70 20 28 63 6f 6e 66 69 67 66 3a 72 (loop (configf:r
35d0: 65 61 64 2d 6c 69 6e 65 20 69 6e 70 20 72 65 73 ead-line inp res
35e0: 20 28 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 79 73 (calc-allow-sys
35f0: 74 65 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d tem allow-system
3600: 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 curr-section-na
3610: 6d 65 20 73 65 63 74 69 6f 6e 73 29 20 73 65 74 me sections) set
3620: 74 69 6e 67 73 29 20 63 75 72 72 2d 73 65 63 74 tings) curr-sect
3630: 69 6f 6e 2d 6e 61 6d 65 20 6b 65 79 20 23 66 29 ion-name key #f)
3640: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 66 )).. (conf
3650: 69 67 66 3a 6b 65 79 2d 76 61 6c 2d 70 72 20 28 igf:key-val-pr (
3660: 20 78 20 6b 65 79 20 75 6e 6b 31 20 76 61 6c 20 x key unk1 val
3670: 75 6e 6b 32 20 29 20 28 6c 65 74 2a 20 28 28 61 unk2 ) (let* ((a
3680: 6c 69 73 74 20 20 20 28 68 61 73 68 2d 74 61 62 list (hash-tab
3690: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
36a0: 65 73 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d es curr-section-
36b0: 6e 61 6d 65 20 27 28 29 29 29 0a 09 09 09 09 09 name '()))......
36c0: 09 09 09 20 20 28 65 6e 76 61 72 20 20 20 28 61 ... (envar (a
36d0: 6e 64 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 20 nd environ-patt
36e0: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 28 (string-search (
36f0: 72 65 67 65 78 70 20 65 6e 76 69 72 6f 6e 2d 70 regexp environ-p
3700: 61 74 74 29 20 63 75 72 72 2d 73 65 63 74 69 6f att) curr-sectio
3710: 6e 2d 6e 61 6d 65 29 29 29 0a 09 09 09 09 09 09 n-name))).......
3720: 09 09 20 20 28 72 65 61 6c 76 61 6c 20 28 69 66 .. (realval (if
3730: 20 65 6e 76 61 72 0a 09 09 09 09 09 09 09 09 09 envar..........
3740: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 3a 65 (config:e
3750: 76 61 6c 2d 73 74 72 69 6e 67 2d 69 6e 2d 65 6e val-string-in-en
3760: 76 69 72 6f 6e 6d 65 6e 74 20 76 61 6c 29 0a 09 vironment val)..
3770: 09 09 09 09 09 09 09 09 20 20 20 20 20 20 20 76 ........ v
3780: 61 6c 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 al)))........
3790: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
37a0: 6e 66 6f 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 6 *default-l
37b0: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 61 64 2d 63 og-port* "read-c
37c0: 6f 6e 66 69 67 20 65 6e 76 20 73 65 74 74 69 6e onfig env settin
37d0: 67 2c 20 65 6e 76 61 72 3a 20 22 20 65 6e 76 61 g, envar: " enva
37e0: 72 20 22 20 72 65 61 6c 76 61 6c 3a 20 22 20 72 r " realval: " r
37f0: 65 61 6c 76 61 6c 20 22 20 76 61 6c 3a 20 22 20 ealval " val: "
3800: 76 61 6c 20 22 20 6b 65 79 3a 20 22 20 6b 65 79 val " key: " key
3810: 20 22 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d " curr-section-
3820: 6e 61 6d 65 3a 20 22 20 63 75 72 72 2d 73 65 63 name: " curr-sec
3830: 74 69 6f 6e 2d 6e 61 6d 65 29 0a 09 09 09 09 09 tion-name)......
3840: 09 09 20 20 20 20 20 28 69 66 20 65 6e 76 61 72 .. (if envar
3850: 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 6b 65 (safe-setenv ke
3860: 79 20 72 65 61 6c 76 61 6c 29 29 0a 09 09 09 09 y realval)).....
3870: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
3880: 72 69 6e 74 20 31 30 20 2a 64 65 66 61 75 6c 74 rint 10 *default
3890: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 73 -log-port* " s
38a0: 65 74 74 69 6e 67 3a 20 5b 22 20 63 75 72 72 2d etting: [" curr-
38b0: 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 22 5d 20 section-name "]
38c0: 22 20 6b 65 79 20 22 20 3d 20 22 20 76 61 6c 29 " key " = " val)
38d0: 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 68 61 ........ (ha
38e0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 sh-table-set! re
38f0: 73 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e s curr-section-n
3900: 61 6d 65 20 0a 09 09 09 09 09 09 09 09 09 20 20 ame ..........
3910: 20 20 20 20 28 63 6f 6e 66 69 67 3a 61 73 73 6f (config:asso
3920: 63 2d 73 61 66 65 2d 61 64 64 20 61 6c 69 73 74 c-safe-add alist
3930: 20 6b 65 79 20 72 65 61 6c 76 61 6c 20 6d 65 74 key realval met
3940: 61 64 61 74 61 3a 20 6d 65 74 61 70 61 74 68 29 adata: metapath)
3950: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 6c )........ (l
3960: 6f 6f 70 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 oop (configf:rea
3970: 64 2d 6c 69 6e 65 20 69 6e 70 20 72 65 73 20 28 d-line inp res (
3980: 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 79 73 74 65 calc-allow-syste
3990: 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 63 m allow-system c
39a0: 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 urr-section-name
39b0: 20 73 65 63 74 69 6f 6e 73 29 20 73 65 74 74 69 sections) setti
39c0: 6e 67 73 29 20 63 75 72 72 2d 73 65 63 74 69 6f ngs) curr-sectio
39d0: 6e 2d 6e 61 6d 65 20 6b 65 79 20 23 66 29 29 29 n-name key #f)))
39e0: 0a 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 61 .. ;; if a
39f0: 20 63 6f 6e 74 69 6e 75 65 64 20 6c 69 6e 65 0a continued line.
3a00: 09 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 . (configf
3a10: 3a 63 6f 6e 74 2d 6c 6e 2d 72 78 20 28 20 78 20 :cont-ln-rx ( x
3a20: 77 68 73 70 20 76 61 6c 20 20 20 20 20 29 20 28 whsp val ) (
3a30: 6c 65 74 20 28 28 61 6c 69 73 74 20 28 68 61 73 let ((alist (has
3a40: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3a50: 75 6c 74 20 72 65 73 20 63 75 72 72 2d 73 65 63 ult res curr-sec
3a60: 74 69 6f 6e 2d 6e 61 6d 65 20 27 28 29 29 29 29 tion-name '())))
3a70: 0a 09 09 09 09 09 09 28 69 66 20 76 61 72 2d 66 .......(if var-f
3a80: 6c 61 67 20 20 20 20 20 20 20 20 20 20 20 20 20 lag
3a90: 3b 3b 20 69 66 20 73 65 74 20 74 6f 20 61 20 73 ;; if set to a s
3aa0: 74 72 69 6e 67 20 74 68 65 6e 20 77 65 20 68 61 tring then we ha
3ab0: 76 65 20 61 20 63 6f 6e 74 69 6e 75 65 64 20 76 ve a continued v
3ac0: 61 72 0a 09 09 09 09 09 09 20 20 20 20 28 6c 65 ar....... (le
3ad0: 74 20 28 28 6e 65 77 76 61 6c 20 28 63 6f 6e 63 t ((newval (conc
3ae0: 20 0a 09 09 09 09 09 09 09 09 20 20 20 28 63 6f ......... (co
3af0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 72 65 73 20 nfig-lookup res
3b00: 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d curr-section-nam
3b10: 65 20 76 61 72 2d 66 6c 61 67 29 20 22 5c 6e 22 e var-flag) "\n"
3b20: 0a 09 09 09 09 09 09 09 09 20 20 20 3b 3b 20 74 ......... ;; t
3b30: 72 69 6d 20 6c 65 61 64 20 66 72 6f 6d 20 74 68 rim lead from th
3b40: 65 20 69 6e 63 6f 6d 69 6e 67 20 77 68 73 70 20 e incoming whsp
3b50: 74 6f 20 73 75 70 70 6f 72 74 20 73 6f 6d 65 20 to support some
3b60: 69 6e 64 65 6e 74 69 6e 67 2e 0a 09 09 09 09 09 indenting.......
3b70: 09 09 09 20 20 20 28 69 66 20 6c 65 61 64 0a 09 ... (if lead..
3b80: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 ....... (s
3b90: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3ba0: 20 28 72 65 67 65 78 70 20 6c 65 61 64 29 20 22 (regexp lead) "
3bb0: 22 20 77 68 73 70 29 0a 09 09 09 09 09 09 09 09 " whsp).........
3bc0: 20 20 20 20 20 20 20 22 22 29 0a 09 09 09 09 09 "")......
3bd0: 09 09 09 20 20 20 76 61 6c 29 29 29 0a 09 09 09 ... val)))....
3be0: 09 09 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ... ;; (pri
3bf0: 6e 74 20 22 76 61 6c 3a 20 22 20 76 61 6c 20 22 nt "val: " val "
3c00: 5c 6e 6e 65 77 76 61 6c 3a 20 5c 22 22 20 6e 65 \nnewval: \"" ne
3c10: 77 76 61 6c 20 22 5c 22 5c 6e 76 61 72 66 6c 61 wval "\"\nvarfla
3c20: 67 3a 20 22 20 76 61 72 2d 66 6c 61 67 29 0a 09 g: " var-flag)..
3c30: 09 09 09 09 09 20 20 20 20 20 20 28 68 61 73 68 ..... (hash
3c40: 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 20 -table-set! res
3c50: 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d curr-section-nam
3c60: 65 20 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 e .........
3c70: 20 20 28 63 6f 6e 66 69 67 3a 61 73 73 6f 63 2d (config:assoc-
3c80: 73 61 66 65 2d 61 64 64 20 61 6c 69 73 74 20 76 safe-add alist v
3c90: 61 72 2d 66 6c 61 67 20 6e 65 77 76 61 6c 20 6d ar-flag newval m
3ca0: 65 74 61 64 61 74 61 3a 20 6d 65 74 61 70 61 74 etadata: metapat
3cb0: 68 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 h)).......
3cc0: 28 6c 6f 6f 70 20 28 63 6f 6e 66 69 67 66 3a 72 (loop (configf:r
3cd0: 65 61 64 2d 6c 69 6e 65 20 69 6e 70 20 72 65 73 ead-line inp res
3ce0: 20 28 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 79 73 (calc-allow-sys
3cf0: 74 65 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d tem allow-system
3d00: 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 curr-section-na
3d10: 6d 65 20 73 65 63 74 69 6f 6e 73 29 20 73 65 74 me sections) set
3d20: 74 69 6e 67 73 29 20 63 75 72 72 2d 73 65 63 74 tings) curr-sect
3d30: 69 6f 6e 2d 6e 61 6d 65 20 76 61 72 2d 66 6c 61 ion-name var-fla
3d40: 67 20 28 69 66 20 6c 65 61 64 20 6c 65 61 64 20 g (if lead lead
3d50: 77 68 73 70 29 29 29 0a 09 09 09 09 09 09 20 20 whsp))).......
3d60: 20 20 28 6c 6f 6f 70 20 28 63 6f 6e 66 69 67 66 (loop (configf
3d70: 3a 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 20 72 :read-line inp r
3d80: 65 73 20 28 63 61 6c 63 2d 61 6c 6c 6f 77 2d 73 es (calc-allow-s
3d90: 79 73 74 65 6d 20 61 6c 6c 6f 77 2d 73 79 73 74 ystem allow-syst
3da0: 65 6d 20 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d em curr-section-
3db0: 6e 61 6d 65 20 73 65 63 74 69 6f 6e 73 29 20 73 name sections) s
3dc0: 65 74 74 69 6e 67 73 29 20 63 75 72 72 2d 73 65 ettings) curr-se
3dd0: 63 74 69 6f 6e 2d 6e 61 6d 65 20 23 66 20 23 66 ction-name #f #f
3de0: 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 65 6c )))).. (el
3df0: 73 65 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d se (debug:print-
3e00: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
3e10: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 72 6f 62 -log-port* "prob
3e20: 6c 65 6d 20 70 61 72 73 69 6e 67 20 22 20 70 61 lem parsing " pa
3e30: 74 68 20 22 2c 5c 6e 20 20 20 5c 22 22 20 69 6e th ",\n \"" in
3e40: 6c 20 22 5c 22 22 29 0a 09 09 20 20 20 20 20 28 l "\"")... (
3e50: 73 65 74 21 20 76 61 72 2d 66 6c 61 67 20 23 66 set! var-flag #f
3e60: 29 0a 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 )... (loop (
3e70: 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 6c 69 6e configf:read-lin
3e80: 65 20 69 6e 70 20 72 65 73 20 28 63 61 6c 63 2d e inp res (calc-
3e90: 61 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 61 6c 6c allow-system all
3ea0: 6f 77 2d 73 79 73 74 65 6d 20 63 75 72 72 2d 73 ow-system curr-s
3eb0: 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 73 65 63 74 ection-name sect
3ec0: 69 6f 6e 73 29 20 73 65 74 74 69 6e 67 73 29 20 ions) settings)
3ed0: 63 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d curr-section-nam
3ee0: 65 20 23 66 20 23 66 29 29 29 29 29 29 29 29 0a e #f #f)))))))).
3ef0: 20 20 0a 3b 3b 20 70 61 74 68 65 6e 76 76 61 72 .;; pathenvvar
3f00: 20 77 69 6c 6c 20 73 65 74 20 74 68 65 20 6e 61 will set the na
3f10: 6d 65 64 20 76 61 72 20 74 6f 20 74 68 65 20 70 med var to the p
3f20: 61 74 68 20 6f 66 20 74 68 65 20 63 6f 6e 66 69 ath of the confi
3f30: 67 0a 28 64 65 66 69 6e 65 20 28 66 69 6e 64 2d g.(define (find-
3f40: 61 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 and-read-config
3f50: 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 6e 76 fname #!key (env
3f60: 69 72 6f 6e 2d 70 61 74 74 20 23 66 29 28 67 69 iron-patt #f)(gi
3f70: 76 65 6e 2d 74 6f 70 70 61 74 68 20 23 66 29 28 ven-toppath #f)(
3f80: 70 61 74 68 65 6e 76 76 61 72 20 23 66 29 29 0a pathenvvar #f)).
3f90: 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 64 (let* ((curr-d
3fa0: 69 72 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 ir (current-di
3fb0: 72 65 63 74 6f 72 79 29 29 0a 20 20 20 20 20 20 rectory)).
3fc0: 20 20 20 28 63 6f 6e 66 69 67 69 6e 66 6f 20 28 (configinfo (
3fd0: 66 69 6e 64 2d 63 6f 6e 66 69 67 20 66 6e 61 6d find-config fnam
3fe0: 65 20 74 6f 70 70 61 74 68 3a 20 67 69 76 65 6e e toppath: given
3ff0: 2d 74 6f 70 70 61 74 68 29 29 0a 09 20 28 74 6f -toppath)).. (to
4000: 70 70 61 74 68 20 20 20 20 28 63 61 72 20 63 6f ppath (car co
4010: 6e 66 69 67 69 6e 66 6f 29 29 0a 09 20 28 63 6f nfiginfo)).. (co
4020: 6e 66 69 67 66 69 6c 65 20 28 63 61 64 72 20 63 nfigfile (cadr c
4030: 6f 6e 66 69 67 69 6e 66 6f 29 29 0a 09 20 28 73 onfiginfo)).. (s
4040: 65 74 2d 66 69 65 6c 64 73 20 28 6c 61 6d 62 64 et-fields (lambd
4050: 61 20 28 63 75 72 72 2d 73 65 63 74 69 6f 6e 20 a (curr-section
4060: 6e 65 78 74 2d 73 65 63 74 69 6f 6e 20 68 74 20 next-section ht
4070: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 28 path)... (
4080: 6c 65 74 20 28 28 66 69 65 6c 64 2d 6e 61 6d 65 let ((field-name
4090: 73 20 28 69 66 20 68 74 20 28 6b 65 79 73 3a 63 s (if ht (keys:c
40a0: 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 onfig-get-fields
40b0: 20 68 74 29 20 27 28 29 29 29 0a 09 09 09 20 20 ht) '()))....
40c0: 20 20 20 28 74 61 72 67 65 74 20 20 20 20 20 20 (target
40d0: 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (or (getenv "MT_
40e0: 54 41 52 47 45 54 22 29 28 61 72 67 73 3a 67 65 TARGET")(args:ge
40f0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
4100: 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 )(args:get-arg "
4110: 2d 74 61 72 67 65 74 22 29 29 29 29 0a 09 09 09 -target"))))....
4120: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4130: 66 6f 20 39 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 9 *default-lo
4140: 67 2d 70 6f 72 74 2a 20 22 73 65 74 2d 66 69 65 g-port* "set-fie
4150: 6c 64 73 20 77 69 74 68 20 66 69 65 6c 64 2d 6e lds with field-n
4160: 61 6d 65 73 3d 22 20 66 69 65 6c 64 2d 6e 61 6d ames=" field-nam
4170: 65 73 20 22 20 74 61 72 67 65 74 3d 22 20 74 61 es " target=" ta
4180: 72 67 65 74 20 22 20 63 75 72 72 2d 73 65 63 74 rget " curr-sect
4190: 69 6f 6e 3d 22 20 63 75 72 72 2d 73 65 63 74 69 ion=" curr-secti
41a0: 6f 6e 20 22 20 6e 65 78 74 2d 73 65 63 74 69 6f on " next-sectio
41b0: 6e 3d 22 20 6e 65 78 74 2d 73 65 63 74 69 6f 6e n=" next-section
41c0: 20 22 20 70 61 74 68 3d 22 20 70 61 74 68 20 22 " path=" path "
41d0: 20 68 74 3d 22 20 68 74 29 0a 09 09 09 20 28 69 ht=" ht).... (i
41e0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 69 f (not (null? fi
41f0: 65 6c 64 2d 6e 61 6d 65 73 29 29 28 6b 65 79 73 eld-names))(keys
4200: 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
4210: 20 66 69 65 6c 64 2d 6e 61 6d 65 73 20 74 61 72 field-names tar
4220: 67 65 74 20 23 66 29 29 29 29 29 29 0a 20 20 20 get #f)))))).
4230: 20 28 69 66 20 74 6f 70 70 61 74 68 20 28 63 68 (if toppath (ch
4240: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 ange-directory t
4250: 6f 70 70 61 74 68 29 29 20 0a 20 20 20 20 28 69 oppath)) . (i
4260: 66 20 28 61 6e 64 20 74 6f 70 70 61 74 68 20 70 f (and toppath p
4270: 61 74 68 65 6e 76 76 61 72 29 28 73 65 74 65 6e athenvvar)(seten
4280: 76 20 70 61 74 68 65 6e 76 76 61 72 20 74 6f 70 v pathenvvar top
4290: 70 61 74 68 29 29 0a 20 20 20 20 28 6c 65 74 20 path)). (let
42a0: 28 28 63 6f 6e 66 69 67 64 61 74 20 20 28 69 66 ((configdat (if
42b0: 20 63 6f 6e 66 69 67 66 69 6c 65 20 0a 09 09 09 configfile ....
42c0: 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 63 (read-config c
42d0: 6f 6e 66 69 67 66 69 6c 65 20 23 66 20 23 74 20 onfigfile #f #t
42e0: 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 65 6e environ-patt: en
42f0: 76 69 72 6f 6e 2d 70 61 74 74 20 70 6f 73 74 2d viron-patt post-
4300: 73 65 63 74 69 6f 6e 2d 70 72 6f 63 73 3a 20 28 section-procs: (
4310: 6c 69 73 74 20 28 63 6f 6e 73 20 22 5e 66 69 65 list (cons "^fie
4320: 6c 64 73 24 22 20 73 65 74 2d 66 69 65 6c 64 73 lds$" set-fields
4330: 29 29 20 23 66 29 29 29 29 0a 20 20 20 20 20 20 )) #f)))).
4340: 28 69 66 20 74 6f 70 70 61 74 68 20 28 63 68 61 (if toppath (cha
4350: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 63 75 nge-directory cu
4360: 72 72 2d 64 69 72 29 29 0a 20 20 20 20 20 20 28 rr-dir)). (
4370: 6c 69 73 74 20 63 6f 6e 66 69 67 64 61 74 20 74 list configdat t
4380: 6f 70 70 61 74 68 20 63 6f 6e 66 69 67 66 69 6c oppath configfil
4390: 65 20 66 6e 61 6d 65 29 29 29 29 0a 0a 28 64 65 e fname))))..(de
43a0: 66 69 6e 65 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f fine (config-loo
43b0: 6b 75 70 20 63 66 67 64 61 74 20 73 65 63 74 69 kup cfgdat secti
43c0: 6f 6e 20 76 61 72 29 0a 20 20 28 69 66 20 28 68 on var). (if (h
43d0: 61 73 68 2d 74 61 62 6c 65 3f 20 63 66 67 64 61 ash-table? cfgda
43e0: 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 t). (let ((
43f0: 73 65 63 74 64 61 74 20 28 68 61 73 68 2d 74 61 sectdat (hash-ta
4400: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4410: 63 66 67 64 61 74 20 73 65 63 74 69 6f 6e 20 27 cfgdat section '
4420: 28 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c ())))..(if (null
4430: 3f 20 73 65 63 74 64 61 74 29 0a 09 20 20 20 20 ? sectdat)..
4440: 23 66 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6d #f.. (let ((m
4450: 61 74 63 68 20 28 61 73 73 6f 63 20 76 61 72 20 atch (assoc var
4460: 73 65 63 74 64 61 74 29 29 29 0a 09 20 20 20 20 sectdat)))..
4470: 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 28 (if match ;; (
4480: 61 6e 64 20 6d 61 74 63 68 20 28 6c 69 73 74 3f and match (list?
4490: 20 6d 61 74 63 68 29 28 3e 20 28 6c 65 6e 67 74 match)(> (lengt
44a0: 68 20 6d 61 74 63 68 29 20 31 29 29 0a 09 09 20 h match) 1))...
44b0: 20 28 63 61 64 72 20 6d 61 74 63 68 29 0a 09 09 (cadr match)...
44c0: 20 20 23 66 29 29 0a 09 20 20 20 20 29 29 0a 20 #f)).. )).
44d0: 20 20 20 20 20 23 66 29 29 0a 0a 28 64 65 66 69 #f))..(defi
44e0: 6e 65 20 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ne configf:looku
44f0: 70 20 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 29 p config-lookup)
4500: 0a 28 64 65 66 69 6e 65 20 63 6f 6e 66 69 67 66 .(define configf
4510: 3a 72 65 61 64 2d 66 69 6c 65 20 72 65 61 64 2d :read-file read-
4520: 63 6f 6e 66 69 67 29 0a 0a 28 64 65 66 69 6e 65 config)..(define
4530: 20 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 69 6f (configf:sectio
4540: 6e 2d 76 61 72 73 20 63 66 67 64 61 74 20 73 65 n-vars cfgdat se
4550: 63 74 69 6f 6e 29 0a 20 20 28 6c 65 74 20 28 28 ction). (let ((
4560: 73 65 63 74 64 61 74 20 28 68 61 73 68 2d 74 61 sectdat (hash-ta
4570: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4580: 63 66 67 64 61 74 20 73 65 63 74 69 6f 6e 20 27 cfgdat section '
4590: 28 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e ()))). (if (n
45a0: 75 6c 6c 3f 20 73 65 63 74 64 61 74 29 0a 09 27 ull? sectdat)..'
45b0: 28 29 0a 09 28 6d 61 70 20 63 61 72 20 73 65 63 ()..(map car sec
45c0: 74 64 61 74 29 29 29 29 0a 0a 28 64 65 66 69 6e tdat))))..(defin
45d0: 65 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 e (configf:get-s
45e0: 65 63 74 69 6f 6e 20 63 66 67 64 61 74 20 73 65 ection cfgdat se
45f0: 63 74 69 6f 6e 29 0a 20 20 28 68 61 73 68 2d 74 ction). (hash-t
4600: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4610: 20 63 66 67 64 61 74 20 73 65 63 74 69 6f 6e 20 cfgdat section
4620: 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 '()))..(define (
4630: 73 65 74 75 70 29 0a 20 20 28 6c 65 74 2a 20 28 setup). (let* (
4640: 28 63 6f 6e 66 69 67 66 20 28 66 69 6e 64 2d 63 (configf (find-c
4650: 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 73 74 2e onfig "megatest.
4660: 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 63 6f 6e config")).. (con
4670: 66 69 67 20 20 28 69 66 20 63 6f 6e 66 69 67 66 fig (if configf
4680: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 63 6f (read-config co
4690: 6e 66 69 67 66 20 23 66 20 23 74 29 20 23 66 29 nfigf #f #t) #f)
46a0: 29 29 0a 20 20 20 20 28 69 66 20 63 6f 6e 66 69 )). (if confi
46b0: 67 0a 09 28 73 65 74 65 6e 76 20 22 52 55 4e 5f g..(setenv "RUN_
46c0: 41 52 45 41 5f 48 4f 4d 45 22 20 28 70 61 74 68 AREA_HOME" (path
46d0: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 63 name-directory c
46e0: 6f 6e 66 69 67 66 29 29 29 0a 20 20 20 20 63 6f onfigf))). co
46f0: 6e 66 69 67 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d nfig))..;;======
4700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4740: 0a 3b 3b 20 4e 6f 6e 20 64 65 73 74 72 75 63 74 .;; Non destruct
4750: 69 76 65 20 77 72 69 74 69 6e 67 20 6f 66 20 63 ive writing of c
4760: 6f 6e 66 69 67 20 66 69 6c 65 0a 3b 3b 3d 3d 3d onfig file.;;===
4770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
47a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
47b0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f ===..(define (co
47c0: 6e 66 69 67 66 3a 63 6f 6d 70 72 65 73 73 2d 6d nfigf:compress-m
47d0: 75 6c 74 69 2d 6c 69 6e 65 73 20 66 64 61 74 29 ulti-lines fdat)
47e0: 0a 20 20 3b 3b 20 73 74 65 70 20 31 2e 35 20 2d . ;; step 1.5 -
47f0: 20 63 6f 6d 70 72 65 73 73 20 61 6e 79 20 63 6f compress any co
4800: 6e 74 69 6e 75 65 64 20 6c 69 6e 65 73 0a 20 20 ntinued lines.
4810: 28 69 66 20 28 6e 75 6c 6c 3f 20 66 64 61 74 29 (if (null? fdat)
4820: 20 66 64 61 74 0a 09 28 6c 65 74 20 6c 6f 6f 70 fdat..(let loop
4830: 20 28 28 68 65 64 20 28 63 61 72 20 66 64 61 74 ((hed (car fdat
4840: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 ))... (tal (cd
4850: 72 20 66 64 61 74 29 29 0a 09 09 20 20 20 28 63 r fdat))... (c
4860: 75 72 20 22 22 29 0a 09 09 20 20 20 28 6c 65 64 ur "")... (led
4870: 20 23 66 29 0a 09 09 20 20 20 28 72 65 73 20 27 #f)... (res '
4880: 28 29 29 29 0a 09 20 20 3b 3b 20 41 4c 4c 20 57 ())).. ;; ALL W
4890: 48 49 54 45 53 50 41 43 45 20 4c 45 41 44 49 4e HITESPACE LEADIN
48a0: 47 20 4c 49 4e 45 53 20 41 52 45 20 54 41 43 4b G LINES ARE TACK
48b0: 45 44 20 4f 4e 21 21 0a 09 20 20 3b 3b 20 20 31 ED ON!!.. ;; 1
48c0: 2e 20 72 65 6d 6f 76 65 20 6c 65 64 20 77 68 69 . remove led whi
48d0: 74 65 73 70 61 63 65 0a 09 20 20 3b 3b 20 20 32 tespace.. ;; 2
48e0: 2e 20 74 61 63 6b 20 6f 6e 20 74 6f 20 68 65 64 . tack on to hed
48f0: 20 77 69 74 68 20 22 5c 6e 22 0a 09 20 20 28 6c with "\n".. (l
4900: 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 et ((match (stri
4910: 6e 67 2d 6d 61 74 63 68 20 63 6f 6e 66 69 67 66 ng-match configf
4920: 3a 63 6f 6e 74 2d 6c 6e 2d 72 78 20 68 65 64 29 :cont-ln-rx hed)
4930: 29 29 0a 09 20 20 20 20 28 69 66 20 6d 61 74 63 )).. (if matc
4940: 68 20 3b 3b 20 62 6c 61 73 74 21 20 68 61 76 65 h ;; blast! have
4950: 20 74 6f 20 64 65 61 6c 20 77 69 74 68 20 61 20 to deal with a
4960: 6d 75 6c 74 69 6c 69 6e 65 0a 09 09 28 6c 65 74 multiline...(let
4970: 2a 20 28 28 6c 65 61 64 20 28 63 61 64 72 20 6d * ((lead (cadr m
4980: 61 74 63 68 29 29 0a 09 09 20 20 20 20 20 20 20 atch))...
4990: 28 6c 76 61 6c 20 28 63 61 64 64 72 20 6d 61 74 (lval (caddr mat
49a0: 63 68 29 29 0a 09 09 20 20 20 20 20 20 20 28 6e ch))... (n
49b0: 65 77 6c 20 28 63 6f 6e 63 20 63 75 72 20 22 5c ewl (conc cur "\
49c0: 6e 22 20 6c 76 61 6c 29 29 29 0a 09 09 20 20 28 n" lval)))... (
49d0: 69 66 20 28 6e 6f 74 20 6c 65 64 29 28 73 65 74 if (not led)(set
49e0: 21 20 6c 65 64 20 6c 65 61 64 29 29 0a 09 09 20 ! led lead))...
49f0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
4a00: 20 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 20 ... (set!
4a10: 66 64 61 74 20 28 61 70 70 65 6e 64 20 66 64 61 fdat (append fda
4a20: 74 20 28 6c 69 73 74 20 6e 65 77 6c 29 29 29 0a t (list newl))).
4a30: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
4a40: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4a50: 20 6e 65 77 6c 20 6c 65 64 20 72 65 73 29 29 29 newl led res)))
4a60: 20 3b 3b 20 4e 42 2f 2f 20 6e 6f 74 20 74 61 63 ;; NB// not tac
4a70: 6b 69 6e 67 20 6e 65 77 6c 20 6f 6e 74 6f 20 72 king newl onto r
4a80: 65 73 0a 09 09 28 6c 65 74 20 28 28 6e 65 77 72 es...(let ((newr
4a90: 65 73 20 28 69 66 20 6c 65 64 20 0a 09 09 09 09 es (if led .....
4aa0: 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c (append res (l
4ab0: 69 73 74 20 63 75 72 20 68 65 64 29 29 0a 09 09 ist cur hed))...
4ac0: 09 09 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 .. (append res
4ad0: 28 6c 69 73 74 20 68 65 64 29 29 29 29 29 0a 09 (list hed)))))..
4ae0: 09 20 20 3b 3b 20 70 72 65 76 20 77 61 73 20 61 . ;; prev was a
4af0: 20 6d 75 6c 74 69 6c 69 6e 65 0a 09 09 20 20 28 multiline... (
4b00: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
4b10: 09 20 20 20 20 20 20 6e 65 77 72 65 73 0a 09 09 . newres...
4b20: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
4b30: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 22 tal)(cdr tal) "
4b40: 22 20 23 66 20 6e 65 77 72 65 73 29 29 29 29 29 " #f newres)))))
4b50: 29 29 29 0a 0a 3b 3b 20 6e 6f 74 65 3a 20 49 27 )))..;; note: I'
4b60: 6d 20 63 68 65 61 74 69 6e 67 20 61 20 6c 69 74 m cheating a lit
4b70: 74 6c 65 20 68 65 72 65 2e 20 49 20 6d 65 72 65 tle here. I mere
4b80: 6c 79 20 72 65 70 6c 61 63 65 20 22 5c 6e 22 20 ly replace "\n"
4b90: 77 69 74 68 20 22 5c 6e 20 20 20 20 20 20 20 20 with "\n
4ba0: 20 22 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 ".(define (conf
4bb0: 69 67 66 3a 65 78 70 61 6e 64 2d 6d 75 6c 74 69 igf:expand-multi
4bc0: 2d 6c 69 6e 65 73 20 66 64 61 74 29 0a 20 20 3b -lines fdat). ;
4bd0: 3b 20 73 74 65 70 20 31 2e 35 20 2d 20 63 6f 6d ; step 1.5 - com
4be0: 70 72 65 73 73 20 61 6e 79 20 63 6f 6e 74 69 6e press any contin
4bf0: 75 65 64 20 6c 69 6e 65 73 0a 20 20 28 69 66 20 ued lines. (if
4c00: 28 6e 75 6c 6c 3f 20 66 64 61 74 29 20 66 64 61 (null? fdat) fda
4c10: 74 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f t. (let loo
4c20: 70 20 28 28 68 65 64 20 28 63 61 72 20 66 64 61 p ((hed (car fda
4c30: 74 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 t))... (tal (cdr
4c40: 20 66 64 61 74 29 29 0a 09 09 20 28 72 65 73 20 fdat))... (res
4c50: 27 28 29 29 29 0a 09 28 6c 65 74 20 28 28 6e 65 '()))..(let ((ne
4c60: 77 72 65 73 20 28 61 70 70 65 6e 64 20 72 65 73 wres (append res
4c70: 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 (list (string-s
4c80: 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 78 ubstitute (regex
4c90: 70 20 22 5c 6e 22 29 20 22 5c 6e 20 20 20 20 20 p "\n") "\n
4ca0: 20 20 20 20 22 20 68 65 64 20 23 74 29 29 29 29 " hed #t))))
4cb0: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
4cc0: 74 61 6c 29 0a 09 20 20 20 20 20 20 6e 65 77 72 tal).. newr
4cd0: 65 73 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 es.. (loop
4ce0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
4cf0: 6c 29 20 6e 65 77 72 65 73 29 29 29 29 29 29 0a l) newres)))))).
4d00: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 69 67 .(define (config
4d10: 66 3a 66 69 6c 65 2d 3e 6c 69 73 74 20 66 6e 61 f:file->list fna
4d20: 6d 65 29 0a 20 20 28 69 66 20 28 66 69 6c 65 2d me). (if (file-
4d30: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 20 exists? fname).
4d40: 20 20 20 20 20 28 6c 65 74 20 28 28 69 6e 70 20 (let ((inp
4d50: 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 66 69 6c 65 (open-input-file
4d60: 20 66 6e 61 6d 65 29 29 29 0a 09 28 6c 65 74 20 fname)))..(let
4d70: 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 loop ((inl (read
4d80: 2d 6c 69 6e 65 20 69 6e 70 29 29 0a 09 09 20 20 -line inp))...
4d90: 20 28 72 65 73 20 27 28 29 29 29 0a 09 20 20 28 (res '())).. (
4da0: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
4db0: 69 6e 6c 29 0a 09 20 20 20 20 20 20 28 62 65 67 inl).. (beg
4dc0: 69 6e 0a 09 09 28 63 6c 6f 73 65 2d 69 6e 70 75 in...(close-inpu
4dd0: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 09 09 28 72 t-port inp)...(r
4de0: 65 76 65 72 73 65 20 72 65 73 29 29 0a 09 20 20 everse res))..
4df0: 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d (loop (read-
4e00: 6c 69 6e 65 20 69 6e 70 29 28 63 6f 6e 73 20 69 line inp)(cons i
4e10: 6e 6c 20 72 65 73 29 29 29 29 29 0a 20 20 20 20 nl res))))).
4e20: 20 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d '()))..;;=====
4e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e70: 3d 0a 3b 3b 20 57 72 69 74 65 20 61 20 63 6f 6e =.;; Write a con
4e80: 66 69 67 0a 3b 3b 20 20 20 30 2e 20 47 69 76 65 fig.;; 0. Give
4e90: 6e 20 61 20 72 65 66 65 72 65 72 65 6e 63 65 20 n a refererence
4ea0: 64 61 74 61 20 73 74 72 75 63 74 75 72 65 20 22 data structure "
4eb0: 69 6e 64 61 74 22 0a 3b 3b 20 20 20 31 2e 20 4f indat".;; 1. O
4ec0: 70 65 6e 20 74 68 65 20 6f 75 74 70 75 74 20 66 pen the output f
4ed0: 69 6c 65 20 61 6e 64 20 72 65 61 64 20 69 74 20 ile and read it
4ee0: 69 6e 74 6f 20 61 20 6c 69 73 74 0a 3b 3b 20 20 into a list.;;
4ef0: 20 32 2e 20 46 6c 61 74 74 65 6e 20 61 6e 79 20 2. Flatten any
4f00: 6d 75 6c 74 69 6c 69 6e 65 20 65 6e 74 72 69 65 multiline entrie
4f10: 73 0a 3b 3b 20 20 20 33 2e 20 4d 6f 64 69 66 79 s.;; 3. Modify
4f20: 20 76 61 6c 75 65 73 20 70 65 72 20 63 6f 6e 74 values per cont
4f30: 65 6e 74 73 20 6f 66 20 22 69 6e 64 61 74 22 20 ents of "indat"
4f40: 61 6e 64 20 72 65 6d 6f 76 65 20 61 62 73 65 6e and remove absen
4f50: 74 20 76 61 6c 75 65 73 0a 3b 3b 20 20 20 34 2e t values.;; 4.
4f60: 20 41 70 70 65 6e 64 20 6e 65 77 20 76 61 6c 75 Append new valu
4f70: 65 73 20 74 6f 20 74 68 65 20 73 65 63 74 69 6f es to the sectio
4f80: 6e 20 28 69 6d 6d 65 64 69 61 74 65 6c 79 20 61 n (immediately a
4f90: 66 74 65 72 20 6c 61 73 74 20 6c 65 67 69 74 20 fter last legit
4fa0: 65 6e 74 72 79 29 0a 3b 3b 20 20 20 35 2e 20 57 entry).;; 5. W
4fb0: 72 69 74 65 20 6f 75 74 20 74 68 65 20 6e 65 77 rite out the new
4fc0: 20 6c 69 73 74 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d list .;;=======
4fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5010: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 69 67 .(define (config
5020: 66 3a 77 72 69 74 65 2d 63 6f 6e 66 69 67 20 69 f:write-config i
5030: 6e 64 61 74 20 66 6e 61 6d 65 20 23 21 6b 65 79 ndat fname #!key
5040: 20 28 72 65 71 75 69 72 65 64 2d 73 65 63 74 69 (required-secti
5050: 6f 6e 73 20 27 28 29 29 29 0a 20 20 28 6c 65 74 ons '())). (let
5060: 2a 20 28 3b 3b 20 73 74 65 70 20 31 3a 20 4f 70 * (;; step 1: Op
5070: 65 6e 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 en the output fi
5080: 6c 65 20 61 6e 64 20 72 65 61 64 20 69 74 20 69 le and read it i
5090: 6e 74 6f 20 61 20 6c 69 73 74 0a 09 20 28 66 64 nto a list.. (fd
50a0: 61 74 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 at (config
50b0: 66 3a 66 69 6c 65 2d 3e 6c 69 73 74 20 66 6e 61 f:file->list fna
50c0: 6d 65 29 29 0a 09 20 28 72 65 66 64 61 74 20 20 me)).. (refdat
50d0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
50e0: 29 29 0a 09 20 28 73 65 63 68 61 73 68 20 28 6d )).. (sechash (m
50f0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
5100: 20 3b 3b 20 63 75 72 72 65 6e 74 20 73 65 63 74 ;; current sect
5110: 69 6f 6e 20 68 61 73 68 2c 20 69 6e 69 74 20 77 ion hash, init w
5120: 69 74 68 20 68 61 73 68 20 66 6f 72 20 22 64 65 ith hash for "de
5130: 66 61 75 6c 74 22 20 73 65 63 74 69 6f 6e 0a 09 fault" section..
5140: 20 28 6e 65 77 20 20 20 20 20 23 66 29 20 3b 3b (new #f) ;;
5150: 20 70 75 74 20 74 68 65 20 6c 69 6e 65 20 74 6f put the line to
5160: 20 62 65 20 75 73 65 64 20 69 6e 20 6e 65 77 2c be used in new,
5170: 20 69 66 20 69 74 20 69 73 20 74 6f 20 62 65 20 if it is to be
5180: 64 65 6c 65 74 65 64 20 74 68 65 20 73 65 74 20 deleted the set
5190: 6e 65 77 20 74 6f 20 23 66 0a 09 20 28 73 65 63 new to #f.. (sec
51a0: 6e 61 6d 65 20 23 66 29 29 0a 0a 20 20 20 20 3b name #f)).. ;
51b0: 3b 20 73 74 65 70 20 32 3a 20 46 6c 61 74 74 65 ; step 2: Flatte
51c0: 6e 20 6d 75 6c 74 69 6c 69 6e 65 20 65 6e 74 72 n multiline entr
51d0: 69 65 73 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ies. (if (not
51e0: 20 28 6e 75 6c 6c 3f 20 66 64 61 74 29 29 28 73 (null? fdat))(s
51f0: 65 74 21 20 66 64 61 74 20 28 63 6f 6e 66 69 67 et! fdat (config
5200: 66 3a 63 6f 6d 70 72 65 73 73 2d 6d 75 6c 74 69 f:compress-multi
5210: 2d 6c 69 6e 65 20 66 64 61 74 29 29 29 0a 0a 20 -line fdat)))..
5220: 20 20 20 3b 3b 20 73 74 65 70 20 33 3a 20 4d 6f ;; step 3: Mo
5230: 64 69 66 79 20 76 61 6c 75 65 73 20 70 65 72 20 dify values per
5240: 63 6f 6e 74 65 6e 74 73 20 6f 66 20 22 69 6e 64 contents of "ind
5250: 61 74 22 20 61 6e 64 20 72 65 6d 6f 76 65 20 61 at" and remove a
5260: 62 73 65 6e 74 20 76 61 6c 75 65 73 0a 20 20 20 bsent values.
5270: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
5280: 20 66 64 61 74 29 29 0a 09 28 6c 65 74 20 6c 6f fdat))..(let lo
5290: 6f 70 20 28 28 68 65 64 20 20 28 63 61 72 20 66 op ((hed (car f
52a0: 64 61 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 dat))... (tal
52b0: 20 28 63 61 64 72 20 66 64 61 74 29 29 0a 09 09 (cadr fdat))...
52c0: 20 20 20 28 72 65 73 20 20 27 28 29 29 0a 09 09 (res '())...
52d0: 20 20 20 28 6c 6e 75 6d 20 30 29 29 0a 09 20 20 (lnum 0))..
52e0: 28 72 65 67 65 78 2d 63 61 73 65 20 0a 09 20 20 (regex-case ..
52f0: 20 68 65 64 0a 09 20 20 20 28 63 6f 6e 66 69 67 hed.. (config
5300: 66 3a 63 6f 6d 6d 65 6e 74 2d 72 78 20 5f 20 20 f:comment-rx _
5310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5320: 28 73 65 74 21 20 72 65 73 20 28 61 70 70 65 6e (set! res (appen
5330: 64 20 72 65 73 20 28 6c 69 73 74 20 68 65 64 29 d res (list hed)
5340: 29 29 29 20 3b 3b 20 28 6c 6f 6f 70 20 28 72 65 ))) ;; (loop (re
5350: 61 64 2d 6c 69 6e 65 20 69 6e 70 29 20 63 75 72 ad-line inp) cur
5360: 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 23 r-section-name #
5370: 66 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e 66 f #f)).. (conf
5380: 69 67 66 3a 62 6c 61 6e 6b 2d 6c 2d 72 78 20 5f igf:blank-l-rx _
5390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53a0: 20 20 28 73 65 74 21 20 72 65 73 20 28 61 70 70 (set! res (app
53b0: 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 65 end res (list he
53c0: 64 29 29 29 29 20 3b 3b 20 28 6c 6f 6f 70 20 28 d)))) ;; (loop (
53d0: 72 65 61 64 2d 6c 69 6e 65 20 69 6e 70 29 20 63 read-line inp) c
53e0: 75 72 72 2d 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 urr-section-name
53f0: 20 23 66 20 23 66 29 29 0a 09 20 20 20 28 63 6f #f #f)).. (co
5400: 6e 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d 72 78 nfigf:section-rx
5410: 20 28 20 78 20 73 65 63 74 69 6f 6e 2d 6e 61 6d ( x section-nam
5420: 65 20 29 20 28 6c 65 74 20 28 28 73 65 63 74 69 e ) (let ((secti
5430: 6f 6e 2d 68 61 73 68 20 28 68 61 73 68 2d 74 61 on-hash (hash-ta
5440: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5450: 72 65 66 64 61 74 20 73 65 63 74 69 6f 6e 2d 6e refdat section-n
5460: 61 6d 65 20 23 66 29 29 29 0a 09 09 09 09 09 20 ame #f)))......
5470: 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 63 74 (if (not sect
5480: 69 6f 6e 2d 68 61 73 68 29 0a 09 09 09 09 09 09 ion-hash).......
5490: 28 6c 65 74 20 28 28 6e 65 77 68 61 73 68 20 28 (let ((newhash (
54a0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
54b0: 29 29 0a 09 09 09 09 09 09 20 20 28 68 61 73 68 ))....... (hash
54c0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 66 68 -table-set! refh
54d0: 61 73 68 20 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 ash section-name
54e0: 20 6e 65 77 68 61 73 68 29 0a 09 09 09 09 09 09 newhash).......
54f0: 20 20 28 73 65 74 21 20 73 65 63 68 61 73 68 20 (set! sechash
5500: 6e 65 77 68 61 73 68 29 29 0a 09 09 09 09 09 09 newhash)).......
5510: 28 73 65 74 21 20 73 65 63 68 61 73 68 20 73 65 (set! sechash se
5520: 63 74 69 6f 6e 2d 68 61 73 68 29 29 0a 09 09 09 ction-hash))....
5530: 09 09 20 20 20 20 28 73 65 74 21 20 6e 65 77 20 .. (set! new
5540: 68 65 64 29 20 3b 3b 20 77 69 6c 6c 20 61 70 70 hed) ;; will app
5550: 65 6e 64 20 74 68 69 73 20 61 74 20 74 68 65 20 end this at the
5560: 62 6f 74 74 6f 6d 20 6f 66 20 74 68 65 20 6c 6f bottom of the lo
5570: 6f 70 0a 09 09 09 09 09 20 20 20 20 28 73 65 74 op...... (set
5580: 21 20 73 65 63 6e 61 6d 65 20 73 65 63 74 69 6f ! secname sectio
5590: 6e 2d 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 n-name)......
55a0: 20 29 29 0a 09 20 20 20 3b 3b 20 4e 6f 20 6e 65 )).. ;; No ne
55b0: 65 64 20 74 6f 20 70 72 6f 63 65 73 73 20 6b 65 ed to process ke
55c0: 79 20 63 6d 64 2c 20 6c 65 74 20 69 74 20 66 61 y cmd, let it fa
55d0: 6c 6c 20 74 68 6f 75 67 68 20 74 6f 20 6b 65 79 ll though to key
55e0: 20 76 61 6c 0a 09 20 20 20 28 63 6f 6e 66 69 67 val.. (config
55f0: 66 3a 6b 65 79 2d 76 61 6c 2d 70 72 20 28 20 78 f:key-val-pr ( x
5600: 20 6b 65 79 20 76 61 6c 20 20 20 20 20 20 29 0a key val ).
5610: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
5620: 6e 65 77 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c newval (config-l
5630: 6f 6f 6b 75 70 20 69 6e 64 61 74 20 73 65 63 20 ookup indat sec
5640: 6b 65 79 29 29 29 0a 09 09 09 20 3b 3b 20 63 61 key))).... ;; ca
5650: 6e 20 68 61 6e 64 6c 65 20 6e 65 77 76 61 6c 20 n handle newval
5660: 3d 3d 20 23 66 20 68 65 72 65 20 3d 3e 20 74 68 == #f here => th
5670: 61 74 20 6d 65 61 6e 73 20 6b 65 79 20 69 73 20 at means key is
5680: 72 65 6d 6f 76 65 64 0a 09 09 09 20 28 63 6f 6e removed.... (con
5690: 64 20 0a 09 09 09 20 20 28 28 65 71 75 61 6c 3f d .... ((equal?
56a0: 20 6e 65 77 76 61 6c 20 76 61 6c 29 0a 09 09 09 newval val)....
56b0: 20 20 20 28 73 65 74 21 20 72 65 73 20 28 61 70 (set! res (ap
56c0: 70 65 6e 64 20 72 65 73 20 28 6c 69 73 74 20 68 pend res (list h
56d0: 65 64 29 29 29 29 0a 09 09 09 20 20 28 28 6e 6f ed)))).... ((no
56e0: 74 20 6e 65 77 76 61 6c 29 20 3b 3b 20 6b 65 79 t newval) ;; key
56f0: 20 68 61 73 20 62 65 65 6e 20 72 65 6d 6f 76 65 has been remove
5700: 64 0a 09 09 09 20 20 20 28 73 65 74 21 20 6e 65 d.... (set! ne
5710: 77 20 23 66 29 29 0a 09 09 09 20 20 28 28 6e 6f w #f)).... ((no
5720: 74 20 28 65 71 75 61 6c 3f 20 6e 65 77 76 61 6c t (equal? newval
5730: 20 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 val)).... (
5740: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
5750: 73 65 63 68 61 73 68 20 6b 65 79 20 6e 65 77 76 sechash key newv
5760: 61 6c 29 0a 09 09 09 20 20 20 20 20 28 73 65 74 al).... (set
5770: 21 20 6e 65 77 20 28 63 6f 6e 63 20 6b 65 79 20 ! new (conc key
5780: 22 20 22 20 6e 65 77 76 61 6c 29 29 29 0a 09 09 " " newval)))...
5790: 09 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 28 . (else.... (
57a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
57b0: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
57c0: 2d 70 6f 72 74 2a 20 22 70 72 6f 62 6c 65 6d 20 -port* "problem
57d0: 70 61 72 73 69 6e 67 20 6c 69 6e 65 20 6e 75 6d parsing line num
57e0: 62 65 72 20 22 20 6c 6e 75 6d 20 22 5c 22 22 20 ber " lnum "\""
57f0: 68 65 64 20 22 5c 22 22 29 29 29 29 29 0a 09 20 hed "\"")))))..
5800: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 28 64 65 (else.. (de
5810: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
5820: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5830: 6f 72 74 2a 20 22 50 72 6f 62 6c 65 6d 20 70 61 ort* "Problem pa
5840: 72 73 69 6e 67 20 6c 69 6e 65 20 6e 75 6d 20 22 rsing line num "
5850: 20 6c 6e 75 6d 20 22 20 3a 5c 6e 20 20 20 22 20 lnum " :\n "
5860: 68 65 64 20 29 29 29 0a 09 20 20 28 69 66 20 28 hed ))).. (if (
5870: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
5880: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
5890: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
58a0: 28 69 66 20 6e 65 77 20 28 61 70 70 65 6e 64 20 (if new (append
58b0: 72 65 73 20 28 6c 69 73 74 20 6e 65 77 29 29 20 res (list new))
58c0: 72 65 73 29 28 2b 20 6c 6e 75 6d 20 31 29 29 29 res)(+ lnum 1)))
58d0: 0a 09 20 20 3b 3b 20 64 72 6f 70 20 74 6f 20 68 .. ;; drop to h
58e0: 65 72 65 20 77 68 65 6e 20 64 6f 6e 65 20 70 72 ere when done pr
58f0: 6f 63 65 73 73 69 6e 67 2c 20 72 65 73 20 63 6f ocessing, res co
5900: 6e 74 61 69 6e 73 20 6d 6f 64 69 66 69 65 64 20 ntains modified
5910: 6c 69 73 74 20 6f 66 20 6c 69 6e 65 73 0a 09 20 list of lines..
5920: 20 28 73 65 74 21 20 66 64 61 74 20 72 65 73 29 (set! fdat res)
5930: 29 29 0a 0a 20 20 20 20 3b 3b 20 73 74 65 70 20 )).. ;; step
5940: 34 3a 20 41 70 70 65 6e 64 20 6e 65 77 20 76 61 4: Append new va
5950: 6c 75 65 73 20 74 6f 20 74 68 65 20 73 65 63 74 lues to the sect
5960: 69 6f 6e 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ion. (for-eac
5970: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
5980: 28 73 65 63 74 69 6f 6e 29 0a 20 20 20 20 20 20 (section).
5990: 20 28 6c 65 74 20 28 28 73 64 61 74 20 20 20 27 (let ((sdat '
59a0: 28 29 29 20 3b 3b 20 61 70 70 65 6e 64 20 6e 65 ()) ;; append ne
59b0: 65 64 65 64 20 62 69 74 73 20 68 65 72 65 0a 09 eded bits here..
59c0: 20 20 20 20 20 28 73 76 61 72 73 20 20 28 63 6f (svars (co
59d0: 6e 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 nfigf:section-va
59e0: 72 73 20 69 6e 64 61 74 20 73 65 63 74 69 6f 6e rs indat section
59f0: 29 29 29 0a 09 20 28 66 6f 72 2d 65 61 63 68 20 ))).. (for-each
5a00: 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 .. (lambda (var
5a10: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 76 61 ).. (let ((va
5a20: 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 l (config-lookup
5a30: 20 72 65 66 64 61 74 20 73 65 63 74 69 6f 6e 20 refdat section
5a40: 76 61 72 29 29 29 0a 09 20 20 20 20 20 20 28 69 var))).. (i
5a50: 66 20 28 6e 6f 74 20 76 61 6c 29 20 3b 3b 20 74 f (not val) ;; t
5a60: 68 69 73 20 6f 6e 65 20 69 73 20 6e 65 77 0a 09 his one is new..
5a70: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
5a80: 28 69 66 20 28 6e 75 6c 6c 3f 20 73 64 61 74 29 (if (null? sdat)
5a90: 28 73 65 74 21 20 73 64 61 74 20 28 6c 69 73 74 (set! sdat (list
5aa0: 20 28 63 6f 6e 63 20 22 5b 22 20 73 65 63 74 69 (conc "[" secti
5ab0: 6f 6e 20 22 5d 22 29 29 29 29 0a 09 09 20 20 20 on "]"))))...
5ac0: 20 28 73 65 74 21 20 73 64 61 74 20 28 61 70 70 (set! sdat (app
5ad0: 65 6e 64 20 73 64 61 74 20 28 6c 69 73 74 20 28 end sdat (list (
5ae0: 63 6f 6e 63 20 76 61 72 20 22 20 22 20 76 61 6c conc var " " val
5af0: 29 29 29 29 29 29 29 29 0a 09 20 20 73 76 61 72 )))))))).. svar
5b00: 73 29 0a 09 20 28 73 65 74 21 20 66 64 61 74 20 s).. (set! fdat
5b10: 28 61 70 70 65 6e 64 20 66 64 61 74 20 73 64 61 (append fdat sda
5b20: 74 29 29 29 29 0a 20 20 20 20 20 28 64 65 6c 65 t)))). (dele
5b30: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 te-duplicates (a
5b40: 70 70 65 6e 64 20 72 65 71 75 69 72 65 2d 73 65 ppend require-se
5b50: 63 74 69 6f 6e 73 20 28 68 61 73 68 2d 74 61 62 ctions (hash-tab
5b60: 6c 65 2d 6b 65 79 73 20 69 6e 64 61 74 29 29 29 le-keys indat)))
5b70: 29 0a 0a 20 20 20 20 3b 3b 20 73 74 65 70 20 35 ).. ;; step 5
5b80: 3a 20 57 72 69 74 65 20 6f 75 74 20 6e 65 77 20 : Write out new
5b90: 66 69 6c 65 0a 20 20 20 20 28 77 69 74 68 2d 6f file. (with-o
5ba0: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e utput-to-file fn
5bb0: 61 6d 65 20 0a 20 20 20 20 20 20 28 6c 61 6d 62 ame . (lamb
5bc0: 64 61 20 28 29 0a 09 28 66 6f 72 2d 65 61 63 68 da ()..(for-each
5bd0: 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 6c 69 6e .. (lambda (lin
5be0: 65 29 0a 09 20 20 20 28 70 72 69 6e 74 20 6c 69 e).. (print li
5bf0: 6e 65 29 29 0a 09 20 28 63 6f 6e 66 69 67 66 3a ne)).. (configf:
5c00: 65 78 70 61 6e 64 2d 6d 75 6c 74 69 2d 6c 69 6e expand-multi-lin
5c10: 65 73 20 66 64 61 74 29 29 29 29 29 29 0a 0a 3b es fdat))))))..;
5c20: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
5c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c60: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 64 62 =======.;; refdb
5c70: 0a 3b 3b 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 3d 3d 3d 3d ================
5cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 72 65 =========..;; re
5cc0: 61 64 73 20 61 20 72 65 66 64 62 20 69 6e 74 6f ads a refdb into
5cd0: 20 61 6e 20 61 73 73 6f 63 20 61 72 72 61 79 20 an assoc array
5ce0: 6f 66 20 61 73 73 6f 63 20 61 72 72 61 79 73 0a of assoc arrays.
5cf0: 3b 3b 20 20 20 72 65 74 75 72 6e 73 20 28 6c 69 ;; returns (li
5d00: 73 74 20 64 61 74 20 6d 73 67 29 0a 28 64 65 66 st dat msg).(def
5d10: 69 6e 65 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 ine (configf:rea
5d20: 64 2d 72 65 66 64 62 20 72 65 66 64 62 2d 70 61 d-refdb refdb-pa
5d30: 74 68 29 0a 20 20 28 6c 65 74 20 28 28 73 68 65 th). (let ((she
5d40: 65 74 73 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 ets-file (conc
5d50: 72 65 66 64 62 2d 70 61 74 68 20 22 2f 73 68 65 refdb-path "/she
5d60: 65 74 2d 6e 61 6d 65 73 2e 63 66 67 22 29 29 29 et-names.cfg")))
5d70: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 . (if (not (f
5d80: 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 68 65 65 ile-exists? shee
5d90: 74 73 2d 66 69 6c 65 29 29 0a 09 28 6c 69 73 74 ts-file))..(list
5da0: 20 23 66 20 28 63 6f 6e 63 20 22 45 52 52 4f 52 #f (conc "ERROR
5db0: 3a 20 6e 6f 20 72 65 66 64 62 20 66 6f 75 6e 64 : no refdb found
5dc0: 20 61 74 20 22 20 72 65 66 64 62 2d 70 61 74 68 at " refdb-path
5dd0: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 66 69 ))..(if (not (fi
5de0: 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
5df0: 73 68 65 65 74 73 2d 66 69 6c 65 29 29 0a 09 20 sheets-file))..
5e00: 20 20 20 28 6c 69 73 74 20 23 66 20 28 63 6f 6e (list #f (con
5e10: 63 20 22 45 52 52 4f 52 3a 20 72 65 66 64 62 20 c "ERROR: refdb
5e20: 66 69 6c 65 20 6e 6f 74 20 72 65 61 64 61 62 6c file not readabl
5e30: 65 20 61 74 20 22 20 72 65 66 64 62 2d 70 61 74 e at " refdb-pat
5e40: 68 29 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 h)).. (let* (
5e50: 28 73 68 65 65 74 73 20 28 77 69 74 68 2d 69 6e (sheets (with-in
5e60: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 73 68 put-from-file sh
5e70: 65 65 74 73 2d 66 69 6c 65 0a 09 09 09 20 20 20 eets-file....
5e80: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 (lambda ()....
5e90: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
5ea0: 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e ((inl (read-lin
5eb0: 65 29 29 0a 09 09 09 09 09 20 20 28 72 65 73 20 e))...... (res
5ec0: 27 28 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 '()))..... (if (
5ed0: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 eof-object? inl)
5ee0: 0a 09 09 09 09 20 20 20 20 20 28 72 65 76 65 72 ..... (rever
5ef0: 73 65 20 72 65 73 29 0a 09 09 09 09 20 20 20 20 se res).....
5f00: 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e (loop (read-lin
5f10: 65 29 28 63 6f 6e 73 20 69 6e 6c 20 72 65 73 29 e)(cons inl res)
5f20: 29 29 29 29 29 29 0a 09 09 20 20 20 28 64 61 74 ))))))... (dat
5f30: 61 20 20 20 27 28 29 29 29 0a 09 20 20 20 20 20 a '()))..
5f40: 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 (for-each ..
5f50: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 68 65 (lambda (she
5f60: 65 74 2d 6e 61 6d 65 29 0a 09 09 20 28 6c 65 74 et-name)... (let
5f70: 2a 20 28 28 64 61 74 2d 70 61 74 68 20 20 28 63 * ((dat-path (c
5f80: 6f 6e 63 20 72 65 66 64 62 2d 70 61 74 68 20 22 onc refdb-path "
5f90: 2f 22 20 73 68 65 65 74 2d 6e 61 6d 65 20 22 2e /" sheet-name ".
5fa0: 64 61 74 22 29 29 0a 09 09 09 28 72 65 66 2d 64 dat"))....(ref-d
5fb0: 61 74 20 20 20 28 63 6f 6e 66 69 67 66 3a 72 65 at (configf:re
5fc0: 61 64 2d 66 69 6c 65 20 64 61 74 2d 70 61 74 68 ad-file dat-path
5fd0: 20 23 66 20 23 74 29 29 0a 09 09 09 28 72 65 66 #f #t))....(ref
5fe0: 2d 61 73 73 6f 63 20 28 6d 61 70 20 28 6c 61 6d -assoc (map (lam
5ff0: 62 64 61 20 28 6b 65 79 29 0a 09 09 09 09 09 20 bda (key)......
6000: 20 28 6c 69 73 74 20 6b 65 79 20 28 68 61 73 68 (list key (hash
6010: 2d 74 61 62 6c 65 2d 72 65 66 20 72 65 66 2d 64 -table-ref ref-d
6020: 61 74 20 6b 65 79 29 29 29 0a 09 09 09 09 09 28 at key)))......(
6030: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
6040: 72 65 66 2d 64 61 74 29 29 29 29 0a 09 09 09 09 ref-dat)))).....
6050: 20 20 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c ;; (hash-tabl
6060: 65 2d 3e 61 6c 69 73 74 20 72 65 66 2d 64 61 74 e->alist ref-dat
6070: 29 29 29 0a 09 09 20 20 20 3b 3b 20 28 73 65 74 )))... ;; (set
6080: 21 20 64 61 74 61 20 28 61 70 70 65 6e 64 20 64 ! data (append d
6090: 61 74 61 20 28 6c 69 73 74 20 28 6c 69 73 74 20 ata (list (list
60a0: 73 68 65 65 74 2d 6e 61 6d 65 20 72 65 66 2d 61 sheet-name ref-a
60b0: 73 73 6f 63 29 29 29 29 29 29 0a 09 09 20 20 20 ssoc))))))...
60c0: 28 73 65 74 21 20 64 61 74 61 20 28 63 6f 6e 73 (set! data (cons
60d0: 20 28 6c 69 73 74 20 73 68 65 65 74 2d 6e 61 6d (list sheet-nam
60e0: 65 20 72 65 66 2d 61 73 73 6f 63 29 20 64 61 74 e ref-assoc) dat
60f0: 61 29 29 29 29 0a 09 20 20 20 20 20 20 20 73 68 a)))).. sh
6100: 65 65 74 73 29 0a 09 20 20 20 20 20 20 28 6c 69 eets).. (li
6110: 73 74 20 64 61 74 61 20 22 4e 4f 20 45 52 52 4f st data "NO ERRO
6120: 52 53 22 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 RS"))))))..;; ma
6130: 70 20 6f 76 65 72 20 61 6c 6c 20 70 61 69 72 73 p over all pairs
6140: 20 69 6e 20 61 20 74 68 72 65 65 20 6c 65 76 65 in a three leve
6150: 6c 20 68 69 65 72 61 72 63 68 69 61 6c 20 61 6c l hierarchial al
6160: 69 73 74 20 61 6e 64 20 61 70 70 6c 79 20 61 20 ist and apply a
6170: 66 75 6e 63 74 69 6f 6e 20 74 6f 20 74 68 65 20 function to the
6180: 6b 65 79 73 2f 76 61 6c 0a 3b 3b 0a 28 64 65 66 keys/val.;;.(def
6190: 69 6e 65 20 28 63 6f 6e 66 69 67 66 3a 6d 61 70 ine (configf:map
61a0: 2d 61 6c 6c 2d 68 69 65 72 2d 61 6c 69 73 74 20 -all-hier-alist
61b0: 64 61 74 61 20 70 72 6f 63 20 23 21 6b 65 79 20 data proc #!key
61c0: 28 69 6e 69 74 70 72 6f 63 31 20 23 66 29 28 69 (initproc1 #f)(i
61d0: 6e 69 74 70 72 6f 63 32 20 23 66 29 28 69 6e 69 nitproc2 #f)(ini
61e0: 74 70 72 6f 63 33 20 23 66 29 29 0a 20 20 28 66 tproc3 #f)). (f
61f0: 6f 72 2d 65 61 63 68 20 0a 20 20 20 28 6c 61 6d or-each . (lam
6200: 62 64 61 20 28 73 68 65 65 74 6e 61 6d 65 29 0a bda (sheetname).
6210: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 68 65 (let* ((she
6220: 65 74 74 6d 70 20 20 28 61 73 73 6f 63 20 73 68 ettmp (assoc sh
6230: 65 65 74 6e 61 6d 65 20 64 61 74 61 29 29 0a 09 eetname data))..
6240: 20 20 20 20 28 73 68 65 65 74 64 61 74 20 20 28 (sheetdat (
6250: 69 66 20 73 68 65 65 74 74 6d 70 20 28 63 61 64 if sheettmp (cad
6260: 72 20 73 68 65 65 74 74 6d 70 29 20 27 28 29 29 r sheettmp) '())
6270: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 69 6e )). (if in
6280: 69 74 70 72 6f 63 31 20 28 69 6e 69 74 70 72 6f itproc1 (initpro
6290: 63 31 20 73 68 65 65 74 6e 61 6d 65 29 29 0a 20 c1 sheetname)).
62a0: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
62b0: 0a 09 28 6c 61 6d 62 64 61 20 28 73 65 63 74 69 ..(lambda (secti
62c0: 6f 6e 6e 61 6d 65 29 0a 09 20 20 28 6c 65 74 2a onname).. (let*
62d0: 20 28 28 73 65 63 74 69 6f 6e 74 6d 70 20 20 28 ((sectiontmp (
62e0: 61 73 73 6f 63 20 73 65 63 74 69 6f 6e 6e 61 6d assoc sectionnam
62f0: 65 20 73 68 65 65 74 64 61 74 29 29 0a 09 09 20 e sheetdat))...
6300: 28 73 65 63 74 69 6f 6e 64 61 74 20 20 28 69 66 (sectiondat (if
6310: 20 73 65 63 74 69 6f 6e 74 6d 70 20 28 63 61 64 sectiontmp (cad
6320: 72 20 73 65 63 74 69 6f 6e 74 6d 70 29 20 27 28 r sectiontmp) '(
6330: 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 69 6e )))).. (if in
6340: 69 74 70 72 6f 63 32 20 28 69 6e 69 74 70 72 6f itproc2 (initpro
6350: 63 32 20 73 68 65 65 74 6e 61 6d 65 20 73 65 63 c2 sheetname sec
6360: 74 69 6f 6e 6e 61 6d 65 29 29 0a 09 20 20 20 20 tionname))..
6370: 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 (for-each..
6380: 28 6c 61 6d 62 64 61 20 28 76 61 72 6e 61 6d 65 (lambda (varname
6390: 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ).. (let*
63a0: 28 28 76 61 6c 74 6d 70 20 28 61 73 73 6f 63 20 ((valtmp (assoc
63b0: 76 61 72 6e 61 6d 65 20 73 65 63 74 69 6f 6e 64 varname sectiond
63c0: 61 74 29 29 0a 09 09 20 20 20 20 20 20 28 76 61 at))... (va
63d0: 6c 20 20 20 20 28 69 66 20 76 61 6c 74 6d 70 20 l (if valtmp
63e0: 28 63 61 64 72 20 76 61 6c 74 6d 70 29 20 22 22 (cadr valtmp) ""
63f0: 29 29 29 0a 09 09 20 28 70 72 6f 63 20 73 68 65 )))... (proc she
6400: 65 74 6e 61 6d 65 20 73 65 63 74 69 6f 6e 6e 61 etname sectionna
6410: 6d 65 20 76 61 72 6e 61 6d 65 20 76 61 6c 29 29 me varname val))
6420: 29 0a 09 20 20 20 20 20 28 6d 61 70 20 63 61 72 ).. (map car
6430: 20 73 65 63 74 69 6f 6e 64 61 74 29 29 29 29 0a sectiondat)))).
6440: 09 28 6d 61 70 20 63 61 72 20 73 68 65 65 74 64 .(map car sheetd
6450: 61 74 29 29 29 29 0a 20 20 20 28 6d 61 70 20 63 at)))). (map c
6460: 61 72 20 64 61 74 61 29 29 0a 20 20 64 61 74 61 ar data)). data
6470: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
6480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
64c0: 43 20 4f 20 4e 20 46 20 49 20 47 20 20 20 54 20 C O N F I G T
64d0: 4f 20 2f 20 46 20 52 20 4f 20 4d 20 20 20 41 20 O / F R O M A
64e0: 4c 20 49 20 53 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d L I S T.;;======
64f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6530: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 69 ..(define (confi
6540: 67 66 3a 63 6f 6e 66 69 67 2d 3e 61 6c 69 73 74 gf:config->alist
6550: 20 63 66 67 64 61 74 29 0a 20 20 28 68 61 73 68 cfgdat). (hash
6560: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 63 66 -table->alist cf
6570: 67 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 gdat))..(define
6580: 28 63 6f 6e 66 69 67 66 3a 61 6c 69 73 74 2d 3e (configf:alist->
6590: 63 6f 6e 66 69 67 20 61 64 61 74 29 0a 20 20 28 config adat). (
65a0: 6c 65 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 let ((ht (make-h
65b0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
65c0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
65d0: 28 6c 61 6d 62 64 61 20 28 73 65 63 74 69 6f 6e (lambda (section
65e0: 29 0a 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 ). (hash-t
65f0: 61 62 6c 65 2d 73 65 74 21 20 68 74 20 28 63 61 able-set! ht (ca
6600: 72 20 73 65 63 74 69 6f 6e 29 28 63 64 72 20 73 r section)(cdr s
6610: 65 63 74 69 6f 6e 29 29 29 0a 20 20 20 20 20 61 ection))). a
6620: 64 61 74 29 0a 20 20 20 20 68 74 29 29 0a 0a 28 dat). ht))..(
6630: 64 65 66 69 6e 65 20 28 63 6f 6e 66 69 67 66 3a define (configf:
6640: 72 65 61 64 2d 61 6c 69 73 74 20 66 6e 61 6d 65 read-alist fname
6650: 29 0a 20 20 28 63 6f 6e 66 69 67 66 3a 61 6c 69 ). (configf:ali
6660: 73 74 2d 3e 63 6f 6e 66 69 67 0a 20 20 20 28 77 st->config. (w
6670: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
6680: 69 6c 65 20 66 6e 61 6d 65 20 72 65 61 64 29 29 ile fname read))
6690: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6e 66 )..(define (conf
66a0: 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 74 20 igf:write-alist
66b0: 63 64 61 74 20 66 6e 61 6d 65 29 0a 20 20 28 77 cdat fname). (w
66c0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
66d0: 6c 65 20 66 6e 61 6d 65 0a 20 20 20 20 28 6c 61 le fname. (la
66e0: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 28 70 mbda (). (p
66f0: 70 20 28 63 6f 6e 66 69 67 66 3a 63 6f 6e 66 69 p (configf:confi
6700: 67 2d 3e 61 6c 69 73 74 20 63 64 61 74 29 29 29 g->alist cdat)))
6710: 29 29 0a 20 20 20 20 20 0a 0a 3b 3b 20 63 6f 6e )). ..;; con
6720: 76 65 72 74 20 68 69 65 72 61 72 63 68 69 61 6c vert hierarchial
6730: 20 6c 69 73 74 20 74 6f 20 69 6e 69 20 66 6f 72 list to ini for
6740: 6d 61 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 mat.;;.(define (
6750: 63 6f 6e 66 69 67 66 3a 63 6f 6e 66 69 67 2d 3e configf:config->
6760: 69 6e 69 20 64 61 74 61 29 0a 20 20 28 6d 61 70 ini data). (map
6770: 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 73 65 . (lambda (se
6780: 63 74 69 6f 6e 29 0a 20 20 20 20 20 28 6c 65 74 ction). (let
6790: 20 28 28 73 65 63 74 69 6f 6e 2d 6e 61 6d 65 20 ((section-name
67a0: 28 63 61 72 20 73 65 63 74 69 6f 6e 29 29 0a 09 (car section))..
67b0: 20 20 20 28 73 65 63 74 69 6f 6e 2d 64 61 74 20 (section-dat
67c0: 20 28 63 64 72 20 73 65 63 74 69 6f 6e 29 29 29 (cdr section)))
67d0: 0a 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
67e0: 5c 6e 5b 22 20 73 65 63 74 69 6f 6e 2d 6e 61 6d \n[" section-nam
67f0: 65 20 22 5d 22 29 0a 20 20 20 20 20 20 20 28 6d e "]"). (m
6800: 61 70 20 28 6c 61 6d 62 64 61 20 28 64 61 74 2d ap (lambda (dat-
6810: 70 61 69 72 29 0a 09 20 20 20 20 20 20 28 6c 65 pair).. (le
6820: 74 2a 20 28 28 76 61 72 20 28 63 61 72 20 64 61 t* ((var (car da
6830: 74 2d 70 61 69 72 29 29 0a 09 09 20 20 20 20 20 t-pair))...
6840: 28 76 61 6c 20 28 63 61 64 72 20 64 61 74 2d 70 (val (cadr dat-p
6850: 61 69 72 29 29 0a 09 09 20 20 20 20 20 28 66 6e air))... (fn
6860: 61 6d 65 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 ame (if (> (leng
6870: 74 68 20 64 61 74 2d 70 61 69 72 29 20 32 29 28 th dat-pair) 2)(
6880: 63 61 64 64 72 20 64 61 74 2d 70 61 69 72 29 20 caddr dat-pair)
6890: 23 66 29 29 29 0a 09 09 28 69 66 20 66 6e 61 6d #f)))...(if fnam
68a0: 65 20 28 70 72 69 6e 74 20 22 23 20 22 20 76 61 e (print "# " va
68b0: 72 20 22 3d 3e 22 20 66 6e 61 6d 65 29 29 0a 09 r "=>" fname))..
68c0: 09 28 70 72 69 6e 74 20 76 61 72 20 22 20 22 20 .(print var " "
68d0: 76 61 6c 29 29 29 0a 09 20 20 20 20 73 65 63 74 val))).. sect
68e0: 69 6f 6e 2d 64 61 74 29 29 29 20 3b 3b 20 20 20 ion-dat))) ;;
68f0: 20 20 20 20 28 70 72 69 6e 74 20 22 73 65 63 74 (print "sect
6900: 69 6f 6e 2d 64 61 74 3a 20 22 20 73 65 63 74 69 ion-dat: " secti
6910: 6f 6e 2d 64 61 74 29 29 0a 20 20 20 28 68 61 73 on-dat)). (has
6920: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 64 h-table->alist d
6930: 61 74 61 29 29 29 0a ata))).