Megatest

Check-in [a9efabed17]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added -setvar, changed environment settings to use double quote instead of single quote
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a9efabed1758d5ddb4fbfca9d873a583ad251e1d
User & Date: matt on 2011-10-30 19:43:42
Other Links: manifest | tags
Context
2011-10-30
21:48
Example run for manual execution of tests check-in: a8bb833bf1 user: matt tags: trunk
19:43
Added -setvar, changed environment settings to use double quote instead of single quote check-in: a9efabed17 user: matt tags: trunk
2011-10-29
21:51
Fixed test of eztest with logpro check-in: bc64078220 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [1ca3176cc8] to [afba6d90ad].

︙
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

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








-
+




-
+






-
+








	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))
	      
(define (save-environment-as-files fname)
  (let ((envvars (get-environment-variables))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%]")))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]")))
     (with-output-to-file (conc fname ".csh")
       (lambda ()
          (for-each (lambda (key)
                      (let* ((val (cdr key))
                             (sval (if (string-search whitesp val)(conc "'" val "'") val)))
                             (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
                        (print "setenv " (car key) " " sval)))
                     envvars)))
     (with-output-to-file (conc fname ".sh")
       (lambda ()
          (for-each (lambda (key)
                      (let* ((val (cdr key))
                             (sval (if (string-search whitesp val)(conc "'" val "'") val)))
                             (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
                         (print "export " (car key) "=" sval)))
                    envvars)))))

;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
(define (alist->env-vars lst)
  (if (list? lst)
︙

Modified dashboard-guimonitor.scm from [2fac0110eb] to [575eae8fef].

︙
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66

52
53
54
55
56
57
58

59
60
61
62
63
64
65
66








-
+








		      (apply
		       iup:vbox
		       (map (lambda (var)
			      (iup:hbox (iup:label var #:size "60x15")
					(iup:textbox   #:expand "HORIZONTAL"
						       #:action (lambda (obj a val)
								  (hash-table-set! var-params var val)))))
			    (list "runname" "testpatts" "itempatts")))))
			    (list "runname" "testpatts" "itempatts" "params")))))
	 (controls   (iup:frame
		      #:title "Controls"
		      (iup:hbox 
		       (iup:frame
			#:title "Runs"
			(iup:hbox 
			 (iup:button "Start"
︙

Modified launch.scm from [c53eb8cfe9] to [d6ce07b497].

︙
52
53
54
55
56
57
58

59
60
61
62
63
64
65













66
67
68
69
70
71
72

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








+







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








	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (ezsteps   (assoc/default 'ezsteps   cmdinfo))
	       (db-host   (assoc/default 'db-host   cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (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)
		(map (lambda (varpair)
		       (let ((varval (string-split varpair "=")))
			 (if (eq? (length varval) 2)
			     (let ((var (car varval))
				   (val (cadr varval)))
			       (debug:print 1 "Adding pre-var/val " var " = " val " to the environment")
			       (setenv var val)))))
		     varpairs)))
	  (setenv "MT_TEST_RUN_DIR" work-area)
	  (setenv "MT_TEST_NAME" test-name)
	  (setenv "MT_ITEM_INFO" (conc itemdat))
	  (setenv "MT_RUNNAME"   runname)
	  (setenv "MT_MEGATEST"  megatest)
	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
︙
352
353
354
355
356
357
358
359

360
361
362
363
364
365
366

366
367
368
369
370
371
372

373
374
375
376
377
378
379
380








-
+








;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch
;;      (launch-test db (cadr status) test-conf))
(define (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat)
(define (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat params)
  (change-directory *toppath*)
  (let ((useshell   (config-lookup *configdat* "jobtools"     "useshell"))
	(launcher   (config-lookup *configdat* "jobtools"     "launcher"))
	(runscript  (config-lookup test-conf   "setup"        "runscript"))
	(ezsteps    (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big
	(diskspace  (config-lookup test-conf   "requirements" "diskspace"))
	(memory     (config-lookup test-conf   "requirements" "memory"))
︙
390
391
392
393
394
395
396
397
398



399
400
401
402
403
404
405
406
407
408
409



410
411
412
413
414
415
416

404
405
406
407
408
409
410


411
412
413
414
415
416
417
418
419
420
421
422


423
424
425
426
427
428
429
430
431
432








-
-
+
+
+









-
-
+
+
+








    ;; set up the run work area for this test
    (set! diskpath (get-best-disk *configdat*))
    (if diskpath
	(let ((dat  (create-work-area db run-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat)))
	(begin
	  (set! work-area test-path)
	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory")))
	  (set! work-area (conc test-path "/tmp_run"))
	  (create-directory work-area #t)
	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
    (set! cmdparms (base64:base64-encode (with-output-to-string
				    (lambda () ;; (list 'hosts     hosts)
				      (write (list (list 'testpath  test-path)
						   (list 'work-area work-area)
						   (list 'test-name test-name) 
						   (list 'runscript runscript) 
						   (list 'run-id    run-id   )
						   (list 'itemdat   itemdat  )
						   (list 'megatest  remote-megatest)
						   (list 'ezsteps   ezsteps)
						   (list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '()))
						   (list 'ezsteps   ezsteps) 
 						   (list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '())) 
						   (list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
						   (list 'runname   runname)
						   (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " "))))
    ;; clean out step records from previous run if they exist
    (db:delete-test-step-records db run-id test-name itemdat)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
    (cond
     ((and launcher hosts) ;; must be using ssh hostname
︙

Modified megatest.scm from [751b469169] to [1013e8e76b].

︙
86
87
88
89
90
91
92
93


94
95
96
97
98
99
100

86
87
88
89
90
91
92

93
94
95
96
97
98
99
100
101








-
+
+








  -rerun FAIL,WARN...     : re-run if called on a test that previously ran (nullified
                            if -keepgoing is also specified)
  -rebuild-db             : bring the database schema up to date
  -rollup                 : fill run (set by :runname)  with latest test(s) from
                            prior runs with same keys
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh

  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
Spreadsheet generation
  -extract-ods            : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style
︙
143
144
145
146
147
148
149

150
151
152
153
154
155
156

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158








+








			":expected"
			":tol"
			":units"
			;; misc
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-debug" ;; for *verbosity* > 2
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"
︙

Modified runs.scm from [a0af6ccbb4] to [631b691194].

︙
707
708
709
710
711
712
713
714

715
716
717
718
719
720
721

707
708
709
710
711
712
713

714
715
716
717
718
719
720
721








-
+








			 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
			 (if (not runflag)
			     (if (not parent-test)
				 (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
			     (let* ((get-prereqs-cmd (lambda ()
						       (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
				    (launch-cmd      (lambda ()
						       (launch-test db run-id (args:get-arg ":runname") test-conf keyvallst test-name test-path itemdat)))
						       (launch-test db run-id (args:get-arg ":runname") test-conf keyvallst test-name test-path itemdat args:arg-hash)))
				    (testrundat      (list get-prereqs-cmd launch-cmd)))
			       (if (or (args:get-arg "-force")
				       (let ((preqs-not-yet-met ((car testrundat))))
					 (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met)
					 (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one...
				   (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
				       (begin
︙
1018
1019
1020
1021
1022
1023
1024
1025

1026
1027
1028
1029
1030
1031
1032

1018
1019
1020
1021
1022
1023
1024

1025
1026
1027
1028
1029
1030
1031
1032








-
+








			 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
			 (if (not runflag)
			     (if (not parent-test)
				 (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
			     (let* ((get-prereqs-cmd (lambda ()
						       (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
				    (launch-cmd      (lambda ()
						       (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat)))
						       (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)))
				    (testrundat      (list get-prereqs-cmd launch-cmd)))
			       (if (or force
				       (let ((preqs-not-yet-met ((car testrundat))))
					 (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met)
					 (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one...
				   (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
				       (begin
︙

Modified tasks.scm from [8e5c677b38] to [3adb7d7095].

︙
299
300
301
302
303
304
305
306

307
308
309
310
311
312
313

299
300
301
302
303
304
305

306
307
308
309
310
311
312
313








-
+








		    (tasks:task-get-test   task)
		    (tasks:task-get-item   task)
		    (tasks:task-get-owner  task)
		    flags)
    (tasks:set-state tdb (tasks:task-get-id task) "waiting")))

(define (tasks:rollup-runs db tdb task)
  (let* ((flags (make-hash-table))
  (let* ((flags (make-hash-table)) 
	 (keys  (db:get-keys db))
	 (keyvallst (keys:target->keyval keys (tasks:task-get-target task))))
    ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
    (print "Starting rollup " task)
    ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
    (runs:rollup-run db
		     keys
︙

Modified tests/megatest.config from [9392b88636] to [238b002f71].

︙
27
28
29
30
31
32
33


34
35
36
37
38
39
40

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42








+
+









# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section
[env-override]
SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs
TESTVAR [system realpath .]
DEADVAR [system ls]
VARWITHDOLLAR $HOME/.zshrc

# XTERM   [system xterm]
# RUNDEAD [system exit 56]

## disks are:
## name host:/path/to/area
## -or-
## name /path/to/area
︙

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