Overview
Comment: | Added partial implementation of env processing |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | envprocessing |
Files: | files | file ages | folders |
SHA1: |
c90d2ff21459820eff48b52c706750dd |
User & Date: | mrwellan on 2016-02-29 16:24:15 |
Other Links: | branch diff | manifest | tags |
Context
2016-02-29
| ||
22:57 | Completed first pass on env handling check-in: 0128bb0fae user: matt tags: envprocessing | |
16:24 | Added partial implementation of env processing check-in: c90d2ff214 user: mrwellan tags: envprocessing | |
2016-02-25
| ||
16:55 | Added envcap functionality Leaf check-in: e2bc4c591a user: mrwellan tags: v1.60 | |
Changes
Modified env.scm from [32a90275e2] to [4f6bdd267e].
︙ | ︙ | |||
39 40 41 42 43 44 45 | (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))))) | | > | | | | | | | | | | | > | > > > > > > | > | > > > > > | > > > > > | > > > > | > > > > | | > > | > > | > > > > > > > > | > > < < < | 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)) |
Modified megatest.scm from [5ea6d9acef] to [2a48def57e].
︙ | ︙ | |||
1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 | (db (env:open-db fname))) (env:save-env-vars db context) (env:close-database db) (set! *didsomething* #t)) (begin (debug:print 0 "ERROR: Parameter to -envcap should be <filename>=<context>. E.G. envdat=original, got: " envcap) (set! *didsomething* #t))))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) | > > > > > > > > > > > > > > | 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 | (db (env:open-db fname))) (env:save-env-vars db context) (env:close-database db) (set! *didsomething* #t)) (begin (debug:print 0 "ERROR: Parameter to -envcap should be <filename>=<context>. E.G. envdat=original, got: " envcap) (set! *didsomething* #t))))) ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b ;; (let ((envdelta (args:get-arg "-envdelta"))) (if envdelta (let ((match (string-match "([a-z]+)=([a-z\-,]+)" envdelta))) (if match (let* ((resctx (cadr match)) (equn (caddr match)) (parts (string-split equn "-")) (minuend (car parts)) (subtraend (cadr parts)) ( ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) |
︙ | ︙ |