23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
-
-
+
+
-
+
-
+
-
+
-
+
+
-
+
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
-
+
-
+
-
+
|
(list path fullpath configname)
(let ((remcwd (take dir (- (length dir) 1))))
(if (null? remcwd)
(list #f #f #f) ;; #f #f)
(loop remcwd))))))))
(define (config:assoc-safe-add alist key val)
(let ((newalist (filter (lambda (x)(not (equal? key x))) alist)))
(append alist (list (list key val)))))
(let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
(append newalist (list (list key val)))))
;; read a config file, returns two level hierarchial hash-table,
;; adds to ht if given (must be #f otherwise)
(define (read-config path . ht)
(define (read-config path ht allow-system)
(if (not (file-exists? path))
(if (null? ht)(make-hash-table) (car ht))
(if (not ht)(make-hash-table) ht)
(let ((inp (open-input-file path))
(res (if (null? ht)(make-hash-table)(car ht)))
(res (if (not ht)(make-hash-table) ht))
(include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
(section-rx (regexp "^\\[(.*)\\]\\s*$"))
(blank-l-rx (regexp "^\\s*$"))
(key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
(key-val-pr (regexp "^(\\S+)\\s+(.*)$"))
(comment-rx (regexp "^\\s*#.*")))
(comment-rx (regexp "^\\s*#.*"))
(cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")))
(let loop ((inl (read-line inp))
(curr-section-name "default"))
(curr-section-name "default")
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
(if (eof-object? inl)
(begin
(close-input-port inp)
res)
(regex-case
inl
(comment-rx _ (loop (read-line inp) curr-section-name))
(blank-l-rx _ (loop (read-line inp) curr-section-name))
(comment-rx _ (loop (read-line inp) curr-section-name #f #f))
(blank-l-rx _ (loop (read-line inp) curr-section-name #f #f))
(include-rx ( x include-file ) (begin
(read-config include-file res)
(loop (read-line inp) curr-section-name)))
(section-rx ( x section-name ) (loop (read-line inp) section-name))
(key-sys-pr ( x key cmd ) (let ((alist (hash-table-ref/default res curr-section-name '()))
(val (let* ((cmdres (cmd-run->list cmd))
(status (cadr cmdres))
(res (car cmdres)))
(if (not (eq? status 0))
(begin
(debug:print 0 "ERROR: problem with " inl ", return code " status)
(exit 1)))
(if (null? res)
""
(string-intersperse res " ")))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key val))
(read-config include-file res allow-system)
(loop (read-line inp) curr-section-name #f #f)))
(section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
(key-sys-pr ( x key cmd ) (if allow-system
(let ((alist (hash-table-ref/default res curr-section-name '()))
(val (let* ((cmdres (cmd-run->list cmd))
(status (cadr cmdres))
(res (car cmdres)))
(if (not (eq? status 0))
(begin
(debug:print 0 "ERROR: problem with " inl ", return code " status)
(exit 1)))
(if (null? res)
""
(string-intersperse res " ")))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key val))
;; (append alist (list (list key val))))
(loop (read-line inp) curr-section-name)))
;; (append alist (list (list key val))))
(loop (read-line inp) curr-section-name)))
val)))
;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist var-flag newval))
(loop (read-line inp) curr-section-name var-flag (if lead lead whsp)))
(loop (read-line inp) curr-section-name #f #f))))
(else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
(loop (read-line inp) curr-section-name))))))))
(loop (read-line inp) curr-section-name #f #f))))))))
(define (find-and-read-config fname)
(let* ((curr-dir (current-directory))
(configinfo (find-config fname))
(toppath (car configinfo))
(configfile (cadr configinfo)))
(if toppath (change-directory toppath))
(let ((configdat (if configfile (read-config configfile) #f))) ;; (make-hash-table))))
(let ((configdat (if configfile (read-config configfile #f #t) #f))) ;; (make-hash-table))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
(define (config-lookup cfgdat section var)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
#f
(let ((match (assoc var sectdat)))
(if match
(cadr match)
#f))
)))
(define (setup)
(let* ((configf (find-config))
(config (if configf (read-config configf) #f)))
(config (if configf (read-config configf #f #t) #f)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
|