18
19
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
;;======================================================================
(declare (unit env))
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
(begin
(exec (sql db "CREATE TABLE envvars (
id INTEGER PRIMARY KEY,
context TEXT NOT NULL,
var TEXT NOT NULL,
val TEXT NOT NULL,
CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
(set-busy-handler! db (busy-timeout 10000))
db))
;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
(with-transaction
db
(lambda ()
;; first clear out any vars for this context
(if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cdr varval)))
(if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
(exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
(if vardat
(hash-table->alist vardat)
(get-environment-variables))))))
;; merge contexts in the order given
;; - each context is applied in the given order
;; - variables in the paths list are split on the separator and the components
;; merged using simple delta addition
;; returns a hash of the merged vars
;;
(define (env:merge-contexts db basecontext contexts paths)
(let ((result (make-hash-table)))
(for-each
(lambda (context)
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var
(if (and (hash-table-ref/default results var #f)
(assoc var paths)) ;; this var is a path and there is a previous path
(let ((sep (cadr (assoc var paths))))
(env:merge-path-envvar sep (hash-table-ref results var) valb))
valb)))))
(sql db "SELECT var,val FROM envvars WHERE context=?")
context))
contexts)
result))
;; get list of removed variables between two contexts
;;
(define (env:get-removed db contexta contextb)
(let ((result (make-hash-table)))
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var val))))
(sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
contexta contextb)
result))
;; get list of variables added to contextb from contexta
;;
(define (env:get-added db contexta contextb)
(let ((result (make-hash-table)))
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var val))))
(sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
contextb contexta)
result))
;; get list of variables in both contexta and contexb that have been changed
;;
(define (env:get-changed db contexta contextb)
(let ((result (make-hash-table)))
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var val))))
(sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")
contextb contexta)
result))
;;
(define (env:blind-merge l1 l2)
(if (null? l1) l2
(if (null? l2) l1
(cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))
;; given a before and an after envvar calculate a new merged path
;;
(define (env:merge-path-envvar separator patha pathb)
(let* ((patha-parts (string-split patha separator))
(pathb-parts (string-split pathb separator))
(common-parts (lset-intersection equal? patha-parts pathb-parts))
(final (delete-duplicates ;; env:blind-merge
(append pathb-parts common-parts patha-parts))))
;; (print "BEFORE: " (string-intersperse patha-parts "\n "))
;; (print "AFTER: " (string-intersperse pathb-parts "\n "))
;; (print "COMMON: " (string-intersperse common-parts "\n "))
(string-intersperse final separator)))
(define (env:process-path-envvar varname separator patha pathb)
(let ((newpath (env:merge-path-envvar separator patha pathb)))
(setenv varname newpath)))
(define (env:have-context db context)
(> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
0))
;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
(close-database db))
(define (env:lazy-hash-table->alist indat)
(if (hash-table? indat)
(let ((dat (hash-table->alist indat)))
(if (null? dat)
#f
dat))
#f))
(define (env:inc-path path)
(print "PATH "
(conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
;; (conc
;; "#{scheme (string-intersperse "
;; "(delete-duplicates "
;; "(append (string-split \"" path "\" \":\") "
;; "(string-split \"#{getenv PATH}\" \":\")))"
;; " \":\")}")))
(define (env:min-path path1 path2)
(string-intersperse
(delete-duplicates
(append
(string-split path1 ":")
(string-split path2 ":")))
":"))
;; inc path will set a PATH that is incrementally modified when read - config mode only
;;
(define (env:print added removed changed #!key (inc-path #t))
(let ((a (env:lazy-hash-table->alist added))
(r (env:lazy-hash-table->alist removed))
(c (env:lazy-hash-table->alist changed)))
(case (if (args:get-arg "-dumpmode")
(string->symbol (args:get-arg "-dumpmode"))
'bash)
((bash)
(if a
(begin
(print "# Added vars")
(map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
(hash-table->alist added))))
(if r
(begin
(print "# Removed vars")
(map (lambda (dat)(print "unset " (car dat)))
(hash-table->alist removed))))
(if c
(begin
(print "# Changed vars")
(map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
(hash-table->alist changed)))))
((csh)
(if a
(begin
(print "# Added vars")
(map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
(hash-table->alist added))))
(if r
(begin
(print "# Removed vars")
(map (lambda (dat)(print "unsetenv " (car dat)))
(hash-table->alist removed))))
(if c
(begin
(print "# Changed vars")
(map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
(hash-table->alist changed)))))
((config ini)
(if a
(begin
(print "# Added vars")
(map (lambda (dat)
(let ((var (car dat))
(val (cdr dat)))
(if (and inc-path
(equal? var "PATH"))
(env:inc-path val)
(print var " " val))))
(hash-table->alist added))))
(if r
(begin
(print "# Removed vars")
(map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
(hash-table->alist removed))))
(if c
(begin
(print "# Changed vars")
(map (lambda (dat)
(let ((var (car dat))
(val (cdr dat)))
(if (and inc-path
(equal? var "PATH"))
(env:inc-path val)
(print var " " val))))
(hash-table->alist changed)))))
(else
(debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
18
19
20
21
22
23
24
|
;;======================================================================
(declare (unit env))
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
|