Megatest

Check-in [a9efabed17]
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

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
	 (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_\\-:;,.\\/%]")))
     (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)))
                        (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)))
                         (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)







|




|






|







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_\\-:;,.\\/%$]")))
     (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)))
                        (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)))
                         (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
		      (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")))))
	 (controls   (iup:frame
		      #:title "Controls"
		      (iup:hbox 
		       (iup:frame
			#:title "Runs"
			(iup:hbox 
			 (iup:button "Start"  







|







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" "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
	       (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))

	       (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)













	  (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)))
	  







>







>
>
>
>
>
>
>
>
>
>
>
>
>







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
;; 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)
  (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"))







|







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 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
    ;; 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! 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 '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







|
>
|









|
|
>







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 (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 '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
  -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


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








|
>







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
			":expected"
			":tol"
			":units"
			;; misc
			"-extract-ods"
			"-pathmod"
			"-env2file"

			"-debug" ;; for *verbosity* > 2
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"







>







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
			 (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)))
				    (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







|







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 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
			 (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)))
				    (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







|







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 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
		    (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))
	 (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 







|







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)) 
	 (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

# 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]


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

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







>
>







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