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
|
(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)))
(get-environment-variables)))))
;; apply contexts to current environment
;; - 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
;;
(define (env:apply-contexts db basecontext contexts paths outputf formats)
(for-each
(lambda (context)
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(vala (cadr row))
(valb (caddr row)))
;;(print "var: " var " vala: " vala " valb" valb " paths: " paths)
(if (assoc var paths) ;; this var is a PATH
(let ((current (get-environment-variable var))) ;; use this NOT vala
;;(pp paths)
;;(pp var)
(env:process-path-envvar var (cadr (assoc var paths)) current valb))
(begin
(setenv var valb))))))
(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val")
;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?")
basecontext context))
contexts))
(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)
(begin
(print "Process-path-envvar: " varname)
)
|
|
>
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
>
>
>
>
|
>
|
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
|
|
>
>
|
>
>
|
>
>
>
>
>
>
>
>
|
>
>
<
<
<
|
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
|
(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)))
(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 valb))))
(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 valb))))
(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 WHERE context=? AND val != (SELECT val FROM envvars WHERE var=? AND context=?)")
contexta contextb))
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))
|