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
|
(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 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*#.*"))
(cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")))
(let loop ((inl (read-line inp))
(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 #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 #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 #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
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
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
|
(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 two level hierarchial hash-table,
;; 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*$"))
(key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
(key-val-pr (regexp "^(\\S+)\\s+(.*)$"))
(comment-rx (regexp "^\\s*#.*"))
(cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")))
(let loop ((inl (read-line inp))
(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 #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
|
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
|
(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))))
(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)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
|
|
|
|
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
|
(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
(let ((match (assoc var sectdat)))
(if match
(cadr match)
#f))
)))
(define (setup)
(let* ((configf (find-config))
(config (if configf (read-config configf #f #t) #f)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
|