Megatest

Check-in [e2bc4c591a]
Login
Overview
Comment:Added envcap functionality
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: e2bc4c591ac9c901a4bf9144b4795858f437b86d
User & Date: mrwellan on 2016-02-25 16:55:33
Other Links: branch diff | manifest | tags
Context
2016-03-06
20:52
Merged envprocessing into v1.60 check-in: a1d77f1a3b user: matt tags: v1.60_defunct
2016-02-29
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
2016-02-24
13:51
Added stats to runs in main.db check-in: 6f76a8815b user: mrwellan tags: v1.60
Changes

Modified Makefile from [2068febfac] to [4047b294e4].

1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20
1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20












-
+







# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
           ods.scm runconfig.scm server.scm configf.scm \
           db.scm keys.scm margs.scm megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   http-transport.scm nmsg-transport.scm filedb.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm \
	   rmt.scm api.scm tdb.scm rpc-transport.scm \
	   portlogger.scm archive.scm
	   portlogger.scm archive.scm env.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

Added env.scm version [32a90275e2].










































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit env))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 nanomsg srfi-18 call-with-environment-variables)

(define (env:open-db fname)
  (let* ((db-exists (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))
  (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)))
	(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)
  ) 
  (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 [9a2b7ba684] to [5ea6d9acef].

39
40
41
42
43
44
45

46
47
48
49
50
51
52
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53







+







(declare (uses daemon))
(declare (uses db))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
154
155
156
157
158
159
160

161
162
163
164
165
166
167
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169







+







  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...

Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -envcap fname=context   : save current variables labeled as context in file fname
  -refdb2dat refdb        : convert refdb to sexp or to format specified by -dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)
  -archive cmd            : archive runs specified by selectors to one of disks specified
                            in the [archive-disks] section.
228
229
230
231
232
233
234

235
236
237
238
239
240
241
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244







+







			"-stop-server"
			"-transport"
			"-kill-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-setvars"
			"-set-state-status"
			"-set-run-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
674
675
676
677
678
679
680
681

682
683
684
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
677
678
679
680
681
682
683

684
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
715
716
717







-
+




-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    (let ((tl        (launch:setup-for-run))
	  (run-id    (and (args:get-arg "-run-id")
			  (string->number (args:get-arg "-run-id")))))
      (if run-id
	  (begin
	    (server:launch run-id)
	    (set! *didsomething* #t))
	  (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))
	  (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))))

    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    (if (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo"
		       "-list-runs"
		       "-ping")))
	(if (launch:setup-for-run)
	    (let ((run-id    (and (args:get-arg "-run-id")
				  (string->number (args:get-arg "-run-id")))))
	      ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  (begin
		    ;; (if run-id 
		    ;;     (client:launch run-id) 
		    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
		    #t
		    ))))))
    ;; (if (null? (lset-intersection 
    ;;     	     equal?
    ;;     	     (hash-table-keys args:arg-hash)
    ;;     	     '("-list-servers"
    ;;     	       "-stop-server"
    ;;     	       "-show-cmdinfo"
    ;;     	       "-list-runs"
    ;;     	       "-ping")))
    ;;     (if (launch:setup-for-run)
    ;;         (let ((run-id    (and (args:get-arg "-run-id")
    ;;     			  (string->number (args:get-arg "-run-id")))))
    ;;           ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
    ;;           ;; if not list or kill then start a client (if appropriate)
    ;;           (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
    ;;     	      (eq? (length (hash-table-keys args:arg-hash)) 0))
    ;;     	  (debug:print-info 1 "Server connection not needed")
    ;;     	  (begin
    ;;     	    ;; (if run-id 
    ;;     	    ;;     (client:launch run-id) 
    ;;     	    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
    ;;     	    #t
    ;;     	    ))))))

;; MAY STILL NEED THIS
;;		       (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))
1873
1874
1875
1876
1877
1878
1879


















1880
1881
1882
1883
1884
1885
1886
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'new2old
       )
      (set! *didsomething* #t)))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (if (substring-index "=" envcap)
	  (let* ((parts   (string-split envcap "="))
		 (fname   (car parts))
		 (context (cadr parts))
		 (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!))

Modified tests/fullrun/multi-dboard.sh from [dbbdc00fad] to [b641343611].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15










16
17
18
19
20
21
22
1
2
3
4
5










6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22





-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+







#!/bin/bash

if [[ ! -e "$HOME/.megatest" ]];then
   mkdir -p "$HOME/.megatest"
fi
if [[ ! -e "$HOME/.megatest/areas.dat" ]];then
   echo "Creating some placeholder files in ~/.megatest"
   cat > "$HOME/.megatest/areas.dat" << EOF
[default]
mfstest /mfs/matt/data/megatest/tests/fullrun
mfsbig /mfs/matt/data/megatest/tests/fdktestqa/testqa
[local]
localtest /home/matt/data/megatest/tests/fullrun
EOF
fi
# if [[ ! -e "$HOME/.megatest/areas.dat" ]];then
#    echo "Creating some placeholder files in ~/.megatest"
#    cat > "$HOME/.megatest/areas.dat" << EOF
# [default]
# mfstest /mfs/matt/data/megatest/tests/fullrun
# mfsbig /mfs/matt/data/megatest/tests/fdktestqa/testqa
# [local]
# localtest /home/matt/data/megatest/tests/fullrun
# EOF
# fi
if [[ ! -e "$HOME/.megatest/default.dat" ]];then
   cat > "$HOME/.megatest/default.dat" << EOF
[fullrun]
path /mfs/matt/data/megatest/tests/fullrun
order 1
# [bigrun]
# path /mfs/matt/data/megatest/tests/fdktestqa/testqa