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
|
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
|
-
-
+
+
-
+
+
-
+
+
+
-
-
+
+
-
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
-
+
|
(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)
(if (not (file-exists? path))
(if (null? ht)(make-hash-table) (car ht))
(let ((inp (open-input-file path))
(res (if (null? ht)(make-hash-table)(car 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))
(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 ) (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)))
(loop (read-line inp) curr-section-name #f #f)))
(key-val-pr ( x key val ) (let ((alist (hash-table-ref/default res curr-section-name '())))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key val))
(loop (read-line inp) curr-section-name key #f)))
;; if a continued line
(cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
(config-lookup res curr-section-name var-flag) "\n"
;; trim lead from the incoming whsp to support some indenting.
(if lead
(string-substitute (regexp lead) "" whsp)
"")
;; (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))
|