| ︙ | | |
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
-
+
|
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
;; read a line and process any #{ ... } constructs
(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)"))
(define (configf:process-line l ht)
(define (configf:process-line l ht allow-system)
(let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
(if matchdat
(let* ((prestr (list-ref matchdat 1))
(cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
(cmd (list-ref matchdat 3))
|
| ︙ | | |
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
+
+
-
-
-
-
+
+
+
+
|
(sect (car parts))
(var (cadr parts)))
(conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))")))
((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(if (or allow-system
(not (member cmdtype '("system" "shell"))))
(with-input-from-string fullcmd
(lambda ()
(set! result ((eval (read)) ht))))
(loop (conc prestr result poststr)))
(with-input-from-string fullcmd
(lambda ()
(set! result ((eval (read)) ht))))
(set! result (conc "#{(" cmdtype ") " cmd "}"))) (loop (conc prestr result poststr)))
res))
res)))
;; Run a shell command and return the output as a string
(define (shell cmd)
(let* ((output (cmd-run->list cmd))
(res (car output))
|
| ︙ | | |
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(define (runconfigs-get config var)
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (configf:lookup config targ var)
(configf:lookup config "default" var))
(configf:lookup config "default" var))))
;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
;;
(define-inline (configf:read-line p ht allow-processing)
(define (configf:read-line p ht allow-processing)
(let loop ((inl (read-line p)))
(let ((cont-line (and (string? inl)
(not (string-null? inl))
(equal? "\\" (string-take-right inl 1)))))
(if cont-line ;; last character is \
(let ((nextl (read-line p)))
(if (not (eof-object? nextl))
(loop (string-append (if cont-line
(string-take inl (- (string-length inl) 1))
inl)
nextl))))
(if (and allow-processing
(not (eq? allow-processing 'return-string)))
(configf:process-line inl ht)
inl)))))
(case allow-processing ;; if (and allow-processing
;; (not (eq? allow-processing 'return-string)))
((#t #f)
(configf:process-line inl ht allow-processing))
((return-string)
inl)
(else
(configf:process-line inl ht allow-processing)))))))
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f))
(debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
(debug:print 9 "START: " path)
(if (not (file-exists? path))
(begin
(debug:print-info 1 "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
#f) ;; (if (not ht)(make-hash-table) ht))
(let ((inp (open-input-file path))
(res (if (not ht)(make-hash-table) ht)))
(let loop ((inl (configf:read-line inp res allow-system)) ;; (read-line inp))
(curr-section-name (if curr-section curr-section "default"))
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
(debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
(if (eof-object? inl)
(begin
(close-input-port inp)
(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
(debug:print 9 "END: " path)
res)
(regex-case
inl
(configf:comment-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(configf:blank-l-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (absolute-pathname? include-file)
include-file
(nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file)))))
(if (file-exists? full-conf)
(begin
;; (push-directory conf-dir)
(debug:print 9 "Including: " full-conf)
(read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections)
;; (pop-directory)
(loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(begin
(debug:print 2 "INFO: include file " include-file " not found (called from " path ")")
(debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")")
(debug:print 2 " " full-conf)
(loop (configf:read-line inp res allow-system) curr-section-name #f #f)))))
(configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system)
;; if we have the sections list then force all settings into "" and delete it later?
(if (or (not sections)
(member section-name sections))
section-name "") ;; stick everything into ""
|
| ︙ | | |
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
-
+
-
+
-
-
+
-
+
|
" output: " cmdres)
(exit 1)))
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
key
key
(case allow-system
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))))
(loop (configf:read-line inp res allow-system) curr-section-name #f #f))
(loop (configf:read-line inp res allow-system) curr-section-name #f #f)))
(configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '()))
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
(debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
(if envar
(if envar (safe-setenv key realval))
(begin
;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval)
(setenv key realval)))
|
| ︙ | | |
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
|
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
|
-
+
+
|
(lambda (sheet-name)
(let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
(ref-dat (configf:read-file dat-path #f #t))
(ref-assoc (map (lambda (key)
(list key (hash-table-ref ref-dat key)))
(hash-table-keys ref-dat))))
;; (hash-table->alist ref-dat)))
(set! data (append data (list (list sheet-name ref-assoc))))))
;; (set! data (append data (list (list sheet-name ref-assoc))))))
(set! data (cons (list sheet-name ref-assoc) data))))
sheets)
(list data "NO ERRORS"))))))
;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
;;
(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
(for-each
|
| ︙ | | |
482
483
484
485
486
487
488
489
|
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(for-each
(lambda (varname)
(let* ((valtmp (assoc varname sectiondat))
(val (if valtmp (cadr valtmp) "")))
(proc sheetname sectionname varname val)))
(map car sectiondat))))
(map car sheetdat))))
(map car data)))
(map car data))
data)
;;======================================================================
;; C O N F I G T O / F R O M A L I S T
;;======================================================================
(define (configf:config->alist cfgdat)
(hash-table->alist cfgdat))
(define (configf:alist->config adat)
(let ((ht (make-hash-table)))
(for-each
(lambda (section)
(hash-table-set! ht (car section)(cdr section)))
adat)
ht))
(define (configf:read-alist fname)
(configf:alist->config
(with-input-from-file fname read)))
(define (configf:write-alist cdat fname)
(with-output-to-file fname
(lambda ()
(pp (configf:config->alist cdat)))))
|