32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
(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 (car x)))) alist)))
(append newalist (list (list key val)))))
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
(define (read-config path ht allow-system)
(if (not (file-exists? path))
(if (not ht)(make-hash-table) ht)
(let ((inp (open-input-file path))
(res (if (not ht)(make-hash-table) ht))
(include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
(section-rx (regexp "^\\[(.*)\\]\\s*$"))
(blank-l-rx (regexp "^\\s*$"))
|
>
>
>
>
>
>
>
>
|
|
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
|
(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 (car x)))) alist)))
(append newalist (list (list key val)))))
(define (config:eval-string-in-environment str)
(let ((cmdres (cmd-run->list (conc "echo " str))))
(if (null? cmdres) ""
(car cmdres))))
;; 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
(define (read-config path ht allow-system #!key (environ-patt #f))
(if (not (file-exists? path))
(if (not ht)(make-hash-table) ht)
(let ((inp (open-input-file path))
(res (if (not ht)(make-hash-table) ht))
(include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
(section-rx (regexp "^\\[(.*)\\]\\s*$"))
(blank-l-rx (regexp "^\\s*$"))
|
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
|
(close-input-port inp)
res)
(regex-case
inl
(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 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))
(loop (read-line inp) curr-section-name #f #f))
(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)
"")
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 #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 #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
|
|
|
>
>
>
|
|
|
|
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
129
130
131
132
133
|
(close-input-port inp)
res)
(regex-case
inl
(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 allow-system environ-patt: environ-patt)
(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))
(loop (read-line inp) curr-section-name #f #f))
(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 '()))
(realval (if (and environ-patt (string-match (regexp environ-patt) curr-section-name))
(config:eval-string-in-environment val)
val)))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval))
(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)
"")
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 #f #f))))))))
(define (find-and-read-config fname #!key (environ-patt #f))
(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 #t environ-patt: environ-patt) #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
|