20
21
22
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
|
;; NOTE: This is the configf module, long term it will replace configf.scm.
(declare (unit mtconfigf))
(module mtconfigf
(
)
(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13)
(import posix)
;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem
;;
;; (define (dummy-function path)
;; (pathname-directory path)
;; (absolute-pathname? path)
;; (normalize-pathname path))
(define debug:print-error print)
(define debug:print print)
(define debug:print-info print)
(define *default-log-port* (current-error-port))
(define (set-debug-printers normal-fn info-fn error-fn default-port)
(if error-fn (set! debug:print-error error-fn))
(if info-fn (set! debug:print-info info-fn))
(if normal-fn (set! debug:print normal-fn))
(if default-port (set! *default-log-port* default-port)))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
(let* ((as-num (if (string? inval)(string->number inval) #f)))
(or as-num inval)))
;; Moved to common
;;
;;;; return list (path fullpath configname)
;;(define (find-config configname #!key (toppath #f))
;; (if toppath
;; (let ((cfname (conc toppath "/" configname)))
;; (if (common:file-exists? cfname)
;; (list toppath cfname configname)
;; (list #f #f #f)))
;; (let* ((cwd (string-split (current-directory) "/")))
;; (let loop ((dir cwd))
;; (let* ((path (conc "/" (string-intersperse dir "/")))
;; (fullpath (conc path "/" configname)))
;; (if (common:file-exists? fullpath)
;; (list path fullpath configname)
;; (let ((remcwd (take dir (- (length dir) 1))))
;; (if (null? remcwd)
;; (list #f #f #f) ;; #f #f)
;; (loop remcwd)))))))))
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
20
21
22
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
129
130
131
132
133
134
135
136
137
138
139
140
141
|
;; NOTE: This is the configf module, long term it will replace configf.scm.
(declare (unit mtconfigf))
(module mtconfigf
(
set-debug-printers
lazy-convert
assoc-safe-add
section-var-set!
safe-file-exists?
read-link-f
nice-path
eval-string-in-environment
safe-setenv
with-env-vars
cmd-run->list
port->list
configf:system
process-line
shell
configf:read-line
cfgdat->env-alist
calc-allow-system
apply-wildcards
val->alist
section->val-alist
read-config
find-config
find-and-read-config
lookup
var-is?
lookup-number
section-vars
get-section
set-section-var
compress-multi-lines
expand-multi-lines
file->list
write-config
read-refdb
map-all-hier-alist
config->alist
alist->config
read-alist
write-alist
config->ini
set-verbosity
)
(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13)
(import posix)
;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem
;;
;; (define (dummy-function path)
;; (pathname-directory path)
;; (absolute-pathname? path)
;; (normalize-pathname path))
;;======================================================================
;;
;; CONVERGE THIS WITH mtcommon.scm debug-print stuff
;;
;;======================================================================
(define *verbosity* 4)
(define (set-verbosity v)(set! *verbosity* v))
(define (tmp-debug-print n e . params)
(if (cond
((list? n)(< (apply min n) *verbosity*))
((number? n) (< n *verbosity*))
(else #f))
(with-output-to-port (or e (current-error-port))
(lambda ()(apply print params)))))
(define debug:print-error tmp-debug-print)
(define debug:print tmp-debug-print)
(define debug:print-info tmp-debug-print)
(define *default-log-port* (current-error-port))
(define (set-debug-printers normal-fn info-fn error-fn default-port)
(if error-fn (set! debug:print-error error-fn))
(if info-fn (set! debug:print-info info-fn))
(if normal-fn (set! debug:print normal-fn))
(if default-port (set! *default-log-port* default-port)))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
(let* ((as-num (if (string? inval)(string->number inval) #f)))
(or as-num inval)))
;; Moved to common
;;
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
(if (safe-file-exists? cfname)
(list toppath cfname configname)
(list #f #f #f)))
(let* ((cwd (string-split (current-directory) "/")))
(let loop ((dir cwd))
(let* ((path (conc "/" (string-intersperse dir "/")))
(fullpath (conc path "/" configname)))
(if (safe-file-exists? fullpath)
(list path fullpath configname)
(let ((remcwd (take dir (- (length dir) 1))))
(if (null? remcwd)
(list #f #f #f) ;; #f #f)
(loop remcwd)))))))))
(define (assoc-safe-add alist key val #!key (metadata #f))
(let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
(append newalist (list (if metadata
(list key val metadata)
(list key val))))))
|
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
|
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
) ;; end loop
)))
;; moved to common.scm as it is very megatest specific
;;
;; ;; pathenvvar will set the named var to the path of the config
;; (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
;; (let* ((curr-dir (current-directory))
;; (configinfo (find-config fname toppath: given-toppath))
;; (toppath (car configinfo))
;; (configfile (cadr configinfo))
;; (set-fields (lambda (curr-section next-section ht path)
;; (let ((field-names (if ht (common:get-fields ht) '()))
;; (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
;; (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
;; (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
;; (if toppath (change-directory toppath))
;; (if (and toppath pathenvvar)(setenv pathenvvar toppath))
;; (let ((configdat (if configfile
;; (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
;; (if toppath (change-directory curr-dir))
;; (list configdat toppath configfile fname))))
|
|
>
<
|
|
|
|
|
<
<
<
<
<
|
|
|
|
>
>
|
|
|
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
|
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
) ;; end loop
)))
;; look at common:set-fields for an example of how to use the set-fields proc
;; pathenvvar will set the named var to the path of the config
;;
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
(toppath (car configinfo))
(configfile (cadr configinfo)))
(if toppath (change-directory toppath))
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt
post-section-procs: (if set-fields (list (cons "^fields$" set-fields)) '())
#f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
(define (lookup cfgdat section var)
(if (hash-table? cfgdat)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
#f
(let ((match (assoc var sectdat)))
|