| ︙ | | |
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
|
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
|
+
+
+
|
configf:section-var-set!
configf:section-vars
configf:set-section-var
configf:var-is?
configf:write-alist
configf:write-config
find-config
getenv
mytarget
nice-path
process:cmd-run->list
runconfig:read
runconfigs-get
safe-setenv
setenv
configf:eval-string-in-environment
)
(import scheme
big-chicken ;; more of a reminder than anything ...
chicken.base
chicken.condition
chicken.file
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
|
| ︙ | | |
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
|
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
|
+
+
+
+
+
+
+
-
-
-
+
+
+
|
z3
)
(define getenv get-environment-variable)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)
;;======================================================================
;; parameters
;;======================================================================
;; while targets are Megatest specific they are a useful concept
(define mytarget (make-parameter #f))
;;======================================================================
;; move debug stuff to separate module then put these back where they belong
;;======================================================================
;;======================================================================
;; lookup routines - replicated from configf
;;======================================================================
(define (configf: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)))
(if match ;; (and match (list? match)(> (length match) 1))
(cadr match)
(let ((res (assoc var sectdat)))
(if res ;; (and match (list? match)(> (length match) 1))
(cadr res)
#f))
))
#f))
(define (configf: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
|
| ︙ | | |
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
|
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
|
-
-
-
+
+
+
|
delta-env-alist))))
(let ((rv (thunk)))
(for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
rv)))
;; return a nice clean pathname made absolute
(define (common:nice-path dir)
(let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
(if match ;; using ~ for home?
(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
(let ((res (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
(if res ;; using ~ for home?
(common:nice-path (conc (common:read-link-f (cadr res)) "/" (caddr res)))
(normalize-pathname (if (absolute-pathname? dir)
dir
(conc (current-directory) "/" dir))))))
;; make "nice-path" available in config files and the repl
(define nice-path common:nice-path)
|
| ︙ | | |
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
|
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
|
-
-
-
-
+
+
+
+
|
(tal (cdr fdat))
(cur "")
(led #f)
(res '()))
;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
;; 1. remove led whitespace
;; 2. tack on to hed with "\n"
(let ((match (string-match configf:cont-ln-rx hed)))
(if match ;; blast! have to deal with a multiline
(let* ((lead (cadr match))
(lval (caddr match))
(let ((res (string-match configf:cont-ln-rx hed)))
(if res ;; blast! have to deal with a multiline
(let* ((lead (cadr res))
(lval (caddr res))
(newl (conc cur "\n" lval)))
(if (not led)(set! led lead))
(if (null? tal)
(set! fdat (append fdat (list newl)))
(loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
(let ((newres (if led
(append res (list cur hed))
|
| ︙ | | |
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
|
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
|
-
+
+
-
+
-
-
-
+
-
+
|
(configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
;;======================================================================
;; Config file handling
;;======================================================================
;; convert to param?
(define configf:std-imports "(import configfmod commonmod)")
(define configf:std-imports "(import big-chicken configfmod commonmod rmtmod)")
(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
(let* ((prestr (list-ref matchdat 1))
(cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
(cmd (list-ref matchdat 3))
(quotedcmd (conc "\""cmd"\""))
(poststr (list-ref matchdat 4))
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd
(if (member cmdsym '(scheme scm))
`(eval-needed
,(conc "(lambda (ht)"
,(conc configf:std-imports
configf:std-imports
"(import chicken.process-context.posix chicken.process-context)"
"(define setenv set-environment-variable)"
(conc "(lambda (ht)" cmd ")")))
((sect var)(configf:lookup ht sect var))
((sect var) `(noeval-needed ,(configf:lookup ht sect var)))
(else
(debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
'(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else `(#f ,(conc "cmd: " cmd " not recognised")))))))
(match
fullcmd
|
| ︙ | | |
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
|
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
|
-
-
+
+
|
(lambda ()
(set! result (if env-to-use
((eval (read) env-to-use) ht)
((eval (read)) ht)
))))
(set! result (conc "#{(" cmdtype ") " cmd "}")))))
(('noeval-needed newres)(set! result newres))
((#f errres)
(debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\".")))
(else ;; (#f errres)
(debug:print 0 *default-log-port* "WARNING: failed to process config input \""l"\", fullcmd="fullcmd".")))
;; we process as a result
(let ((delta (- (current-seconds) start-time)))
(debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))
(conc prestr result poststr)))
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
(let loop ((res l))
|
| ︙ | | |
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
|
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
|
-
-
+
+
|
(loop (conc prestr result poststr)))
res))
res)))
;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config target var)
(let ((targ target #;(common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(define (runconfigs-get config var)
(let ((targ (mytarget) #;(common:args-get-target))) ;; (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))))
;; pathenvvar will set the named var to the path of the config
|
| ︙ | | |