Megatest
Check-in [0f355e8087]
Not logged in
Overview
SHA1:0f355e808706759e60353e7505a815d33f3a5fe6
Date: 2011-11-02 21:58:28
User: matt
Comment:Hacked to get vars working ok. NOT REENTRANT. Must rework :(
Timelines: family | ancestors | envhandling
Downloads: Tarball | ZIP archive
Other Links: files | file ages | folders | manifest
Tags And Properties
Context
2011-11-02
21:59
[da715ac6ab] Merged from envhandling branch (user: matt, tags: trunk, v1.32)
21:58
[0f355e8087] Closed-Leaf: Hacked to get vars working ok. NOT REENTRANT. Must rework :( (user: matt, tags: envhandling)
18:09
[b71bf64192] envvar handling is not reentrant. Need a better solution. Putting this stuff on a branch for now (user: mrwellan, tags: envhandling)
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified configf.scm from [4590f7c875] to [ef264b880e].

88
89
90
91
92
93
94
95
96

97
98



99
100
101
102
103
104
105
106
								 (if (null? res)
								     ""
								     (string-intersperse res " ")))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist key val))
						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let ((alist   (hash-table-ref/default res curr-section-name '()))
						    (realval (if (and environ-patt (string-match (regexp environ-patt) curr-section-name))

								 (config:eval-string-in-environment val)
								 val)))



						(setenv key realval)
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key realval))
						(loop (read-line inp) curr-section-name key #f)))
	       ;; if a continued line
	       (cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 







|
|
>


>
>
>
|







88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
								 (if (null? res)
								     ""
								     (string-intersperse res " ")))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist key val))
						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
						     (envar   (and environ-patt (string-match (regexp environ-patt) curr-section-name)))
						     (realval (if envar
								 (config:eval-string-in-environment val)
								 val)))
						(if envar
						    (begin
						      (debug:print 4 "INFO: read-config key=" key ", val=" val ", realval=" realval)
						      (setenv key realval)))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key realval))
						(loop (read-line inp) curr-section-name key #f)))
	       ;; if a continued line
	       (cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 

Modified launch.scm from [7996f32f59] to [b3346272f9].

58
59
60
61
62
63
64

65
66
67
68
69
70
71
..
86
87
88
89
90
91
92

93
94
95
96
97
98
99
	       (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
	       (set-vars  (assoc/default 'set-vars  cmdinfo)) ;; pre-overrides from -setvar
	       (runname   (assoc/default 'runname   cmdinfo))
	       (megatest  (assoc/default 'megatest  cmdinfo))
	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
	       (fullrunscript (if runscript (conc testpath "/" runscript) #f))
	       (db        #f))

	  (debug:print 2 "Exectuing " test-name " on " (get-host-name))
	  (change-directory testpath)
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
................................................................................
	  
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		(exit 1)))
	  ;; now can find our db
	  (set! db (open-db))

	  (change-directory work-area) 
	  (set-run-config-vars db run-id)
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars db run-id)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")







>







 







>







58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
..
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
	       (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
	       (set-vars  (assoc/default 'set-vars  cmdinfo)) ;; pre-overrides from -setvar
	       (runname   (assoc/default 'runname   cmdinfo))
	       (megatest  (assoc/default 'megatest  cmdinfo))
	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
	       (fullrunscript (if runscript (conc testpath "/" runscript) #f))
	       (db        #f))
	  
	  (debug:print 2 "Exectuing " test-name " on " (get-host-name))
	  (change-directory testpath)
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
................................................................................
	  
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		(exit 1)))
	  ;; now can find our db
	  (set! db (open-db))
	  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
	  (change-directory work-area) 
	  (set-run-config-vars db run-id)
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars db run-id)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")

Modified runconfig.scm from [ddff02cb0f] to [12d1c1602d].

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





23
24
25
26
27
28
29
..
40
41
42
43
44
45
46
47
(declare (uses common))

(include "common_records.scm")

(define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f))
  (let* ((keys    (get-keys db))
	 (keyvals (get-key-vals db run-id))
	 (keyval
	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))
	 (confdat (read-config fname #f #f environ-patt: environ-patt))
	 (whatfound (make-hash-table))
	 (sections (list "default" thekey)))
    (debug:print 4 "Using key=\"" thekey "\"")
    





    (for-each 
     (lambda (section)
       (let ((section-dat (hash-table-ref/default confdat section #f)))
	 (if section-dat
	     (for-each 
	      (lambda (envvar)
		(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
................................................................................
	  (set! *already-seen-runconfig-info* #t)))))

(define (set-run-config-vars db run-id)
  (let ((runconfigf (conc  *toppath* "/runconfigs.config")))
    (if (file-exists? runconfigf)
	(setup-env-defaults db runconfigf run-id #f environ-patt: ".*")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))
  







<





|
>
>
>
>
>







 







|
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
..
44
45
46
47
48
49
50
51
(declare (uses common))

(include "common_records.scm")

(define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f))
  (let* ((keys    (get-keys db))
	 (keyvals (get-key-vals db run-id))

	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))
	 (confdat (read-config fname #f #f environ-patt: environ-patt))
	 (whatfound (make-hash-table))
	 (sections (list "default" thekey)))
    (debug:print 4 "Using key=\"" thekey "\"")

    (for-each
     (lambda (key val)
       (setenv (vector-ref key 0) val))
     keys keyvals)

    (for-each 
     (lambda (section)
       (let ((section-dat (hash-table-ref/default confdat section #f)))
	 (if section-dat
	     (for-each 
	      (lambda (envvar)
		(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
................................................................................
	  (set! *already-seen-runconfig-info* #t)))))

(define (set-run-config-vars db run-id)
  (let ((runconfigf (conc  *toppath* "/runconfigs.config")))
    (if (file-exists? runconfigf)
	(setup-env-defaults db runconfigf run-id #f environ-patt: ".*")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))
 

Modified runs.scm from [cf599e0423] to [5e902b8e73].

548
549
550
551
552
553
554


555
556
557
558
559
560
561
...
588
589
590
591
592
593
594

595

596
597
598
599
600
601
602
...
828
829
830
831
832
833
834


835
836
837
838
839
840
841
	 (keyvallst   (keys->vallist keys #t))
	 (run-id      (register-run db keys))  ;;  test-name)))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 (runconfigf   (conc  *toppath* "/runconfigs.config")))
    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified



    (if (file-exists? runconfigf)
	(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))

    (if (and (eq? *passnum* 0)
	     (args:get-arg "-keepgoing"))
	(begin
................................................................................
	  
;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
(define (run-one-test db run-id test-name keyvallst)
  (debug:print 1 "Launching test " test-name)
  ;; All these vars might be referenced by the testconfig file reader
  (setenv "MT_TEST_NAME" test-name) ;; 
  (setenv "MT_RUNNAME"   (args:get-arg ":runname"))

  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process

  (change-directory *toppath*)
  (let* ((test-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (test-conf    (if testexists (read-config test-configf #f #t) (make-hash-table)))
	 (waiton       (let ((w (config-lookup test-conf "requirements" "waiton")))
			 (if (string? w)(string-split w)'())))
................................................................................
	 (keyvallst   (keys:target->keyval keys target))
	 (run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
	 (test-names  '())
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '()))



    (if (file-exists? runconfigf)
	(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)







>
>







 







>
|
>







 







>
>







548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
...
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
...
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
	 (keyvallst   (keys->vallist keys #t))
	 (run-id      (register-run db keys))  ;;  test-name)))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 (runconfigf   (conc  *toppath* "/runconfigs.config")))
    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified

    (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
    
    (if (file-exists? runconfigf)
	(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))

    (if (and (eq? *passnum* 0)
	     (args:get-arg "-keepgoing"))
	(begin
................................................................................
	  
;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
(define (run-one-test db run-id test-name keyvallst)
  (debug:print 1 "Launching test " test-name)
  ;; All these vars might be referenced by the testconfig file reader
  (setenv "MT_TEST_NAME" test-name) ;; 
  (setenv "MT_RUNNAME"   (args:get-arg ":runname"))

  ;; (set-megatest-env-vars db run-id) ;; these may be needed by the launching process

  (change-directory *toppath*)
  (let* ((test-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (test-conf    (if testexists (read-config test-configf #f #t) (make-hash-table)))
	 (waiton       (let ((w (config-lookup test-conf "requirements" "waiton")))
			 (if (string? w)(string-split w)'())))
................................................................................
	 (keyvallst   (keys:target->keyval keys target))
	 (run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
	 (test-names  '())
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '()))

    (set-megatest-env-vars db run-id) ;; these may be needed by the launching process

    (if (file-exists? runconfigf)
	(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)