Megatest

Check-in [da715ac6ab]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Merged from envhandling branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.32
Files: files | file ages | folders
SHA1: da715ac6abfd64709e7668226a441303749a4b33
User & Date: matt on 2011-11-02 21:59:02
Other Links: manifest | tags
Context
2011-11-03
22:59
Added test placeholders check-in: 5868dd5b31 user: matt tags: trunk
2011-11-02
21:59
Merged from envhandling branch check-in: da715ac6ab user: matt tags: trunk, v1.32
21:58
Hacked to get vars working ok. NOT REENTRANT. Must rework :( Closed-Leaf check-in: 0f355e8087 user: matt tags: envhandling
15:32
Checking in partial fix for envvar handling check-in: ff05a10939 user: mrwellan tags: trunk, v1.31
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified configf.scm from [4a3f07b3f3] to [ef264b880e].

︙
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50

51
52
53
54
55
56
57

36
37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58








-
+







+








(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (list key val)))))

(define (config:eval-string-in-environment str)
  (let ((cmdres (cmd-run->list (conc "echo " str))))
    (if (null? cmdres) ""
	(car cmdres))))
	(caar cmdres))))

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly

(define (read-config path ht allow-system #!key (environ-patt #f))
  (debug:print 4 "INFO: read-config " path " allow-system " allow-system " environ-patt " environ-patt)
  (if (not (file-exists? path))
      (if (not ht)(make-hash-table) ht)
      (let ((inp        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))
︙
87
88
89
90
91
92
93
94
95



96
97




98
99
100
101
102
103
104

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 '()))
						    (realval (if (and environ-patt (string-match (regexp environ-patt) curr-section-name))
	       (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 [ce1a0162c8] to [b3346272f9].

︙
58
59
60
61
62
63
64

65
66
67
68
69
70
71

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72








+








	       (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)
︙
86
87
88
89
90
91
92

93
94
95
96
97
98
99

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101








+








	  
	  (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")
︙
285
286
287
288
289
290
291

292
293

294
295
296
297
298
299
300

287
288
289
290
291
292
293
294
295

296
297
298
299
300
301
302
303








+

-
+








	    ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	    (sqlite3:finalize! db)
	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.
(define (setup-for-run)
  (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")))
  (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") environ-patt: "env-override"))
  (set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
  (set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
  (if *toppath*
      (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated
      (debug:print 0 "ERROR: failed to find the top path to your run setup."))
  *toppath*)
︙

Modified megatest-version.scm from [826d6a379e] to [b46b5a7d77]. 

1
2
3
4
5
6

7

1
2
3
4
5

6
7






-
+


;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.31)
(define megatest-version 1.32)

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

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


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













-
+



-
+



+
+
+
+
+
+










-
-
+











-
+

-
+

;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================

(use format)

(declare (unit runconfig))
(declare (uses common))

(include "common_records.scm")

(define (setup-env-defaults db fname run-id . already-seen)
(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))
	 (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))
		(setenv envvar (cadr (assoc envvar section-dat))))
	      (map car section-dat)))))
     sections)
    (if (and (not (null? already-seen))
	     (not (car already-seen)))
    (if already-seen
	(begin
	  (debug:print 2 "Key settings found in runconfig.config:")
	  (for-each (lambda (fullkey)
		      (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
		    sections)
	  (debug:print 2 "---")
	  (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)
	(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 [b12c8bbbfa] to [5e902b8e73].

︙
548
549
550
551
552
553
554


555
556

557
558
559
560
561
562
563

548
549
550
551
552
553
554
555
556
557

558
559
560
561
562
563
564
565








+
+

-
+








	 (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*)
	(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
	  ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to 
	  ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
︙
588
589
590
591
592
593
594

595


596
597
598
599
600
601
602

590
591
592
593
594
595
596
597

598
599
600
601
602
603
604
605
606








+
-
+
+








	  
;; 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
  ;; (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)'())))
︙
829
830
831
832
833
834
835


836
837

838
839
840
841
842
843
844

833
834
835
836
837
838
839
840
841
842

843
844
845
846
847
848
849
850








+
+

-
+








	 (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*)
	(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)
    (for-each 
     (lambda (patt)
       (let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*")))))
︙
1193
1194
1195
1196
1197
1198
1199
1200
1201


1202
1203
1204
1205
1206
1207
1208

1199
1200
1201
1202
1203
1204
1205


1206
1207
1208
1209
1210
1211
1212
1213
1214








-
-
+
+








	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db   (open-db))
	(set! keys (db-get-keys db))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; evaluate all 
		   (runconfig  (read-config runconfigf #f #f environ-patt: ".*"))) 
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (read-config runconfigf #f #f environ-patt: #f))) 
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    (sqlite3:finalize! db)
		    (exit 1))))
	    (if (args:get-arg "-target")
︙

Modified tests/runconfigs.config from [bf935869e9] to [5386d0e9a5]. 

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




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

13
14
15













-
+
+
+

[/tmp/mrwellan/env/ubuntu/afs]
BOGOUS Bob

[default/ubuntu/nfs]
CURRENT     /blah

[ubuntu/nfs/none]
CURRENT     /tmp/nada


[default]
FOOBARBAZZZZ not a useful value
BIGBOB $BOGOUS/bobby
BIGBOB $FOOBARBAZZZZ/bobby
FREDDY $sysname/$fsname
TOMMY  [system pwd]

This page was generated in about 0.125s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00