Megatest

Diff
Login

Differences From Artifact [1d93c92f83]:

To Artifact [203b993021]:


91
92
93
94
95
96
97
98

99
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
127
128

129
130
131
132
133
134
135
91
92
93
94
95
96
97

98

99
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

127
128
129
130
131
132
133
134







-
+
-










-
+

















-
+







	  (change-directory top-path)
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*)
	  (change-directory *toppath*) 

	  (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
	  (change-directory work-area) 

	  (open-run-close set-run-config-vars #f run-id)
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (open-run-close set-megatest-env-vars #f run-id)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  (open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0)
	  (open-run-close test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
	  (open-run-close tests:test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
	      (if (and fullrunscript (not (file-execute-access? fullrunscript)))
		  (system (conc "chmod ug+x " fullrunscript))))
	  ;; We are about to actually kick off the test
	  ;; so this is a good place to remove the records for 
	  ;; any previous runs
	  ;; (db:test-remove-steps db run-id testname itemdat)
	  
	  (let* ((m            (make-mutex))
		 (kill-job?    #f)
		 (exit-info    (vector #t #t #t))
		 (job-thread   #f)
		 (runit        (lambda ()
				 ;; (let-values
				 ;;  (((pid exit-status exit-code)
				 ;;    (run-n-wait fullrunscript)))
				 (open-run-close test-set-status! #f test-id "RUNNING" "n/a" #f #f)
				 (open-run-close tests:test-set-status! #f test-id "RUNNING" "n/a" #f #f)
				 ;; if there is a runscript do it first
				 (if fullrunscript
				     (let ((pid (process-run fullrunscript)))
				       (let loop ((i 0))
					 (let-values
					  (((pid-val exit-status exit-code) (process-wait pid #t)))
					  (mutex-lock! m)
219
220
221
222
223
224
225
226

227
228
229
230

231
232
233

234
235
236
237
238
239
240
218
219
220
221
222
223
224

225
226
227
228

229
230
231

232
233
234
235
236
237
238
239







-
+



-
+


-
+







						       (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used 
								    " this-step-status: " this-step-status " overall-status: " overall-status 
								    " next-status: " next-status " rollup-status: " rollup-status)
						       (case next-status
							 ((warn)
							  (set! rollup-status 2)
							  ;; NB// test-set-status! does rdb calls under the hood
							  (open-run-close test-set-status! #f test-id "RUNNING" "WARN" 
							  (open-run-close tests:test-set-status! #f test-id "RUNNING" "WARN" 
									    (if (eq? this-step-status 'warn) "Logpro warning found" #f)
									    #f))
							 ((pass)
							  (open-run-close test-set-status! #f test-id "RUNNING" "PASS" #f #f))
							  (open-run-close tests:test-set-status! #f test-id "RUNNING" "PASS" #f #f))
							 (else ;; 'fail
							  (set! rollup-status 1) ;; force fail
							  (open-run-close test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
							  (open-run-close tests:test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
							  ))))
						   (if (and (steprun-good? logpro-used (vector-ref exit-info 2))
							    (not (null? tal)))
						       (loop (car tal) (cdr tal) stepname)))
					     (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
		 (monitorjob   (lambda ()
				 (let* ((start-seconds (current-seconds))
276
277
278
279
280
281
282
283

284
285
286
287
288
289
290
275
276
277
278
279
280
281

282
283
284
285
286
287
288
289







-
+







								(begin
								  (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
								  (system (conc "kill -9 " p-id))))))
							(car processes))
						       (system (conc "kill -9 " pid))))
						   (begin
						     (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						     (open-run-close test-set-status! #f test-id "KILLED"  "FAIL"
						     (open-run-close tests:test-set-status! #f test-id "KILLED"  "FAIL"
								       (args:get-arg "-m") #f)
						     (sqlite3:finalize! tdb)
						     (exit 1))))
					     (set! kill-tries (+ 1 kill-tries))
					     (mutex-unlock! m)))
				       ;; (sqlite3:finalize! db)
				       (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses
300
301
302
303
304
305
306
307

308
309
310
311
312
313
314
299
300
301
302
303
304
305

306
307
308
309
310
311
312
313







-
+







	    ;; (if (not (args:get-arg "-server"))
	    ;;	(server:client-setup db))
	    (let* ((item-path (item-list->path itemdat))
		   (testinfo  (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path)))
	      (if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		  (begin
		    (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
		    (open-run-close test-set-status! #f test-id 
		    (open-run-close tests:test-set-status! #f test-id 
				      (if kill-job? "KILLED" "COMPLETED")
				      ;; Old logic:
				      ;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran
				      ;;     (if (and (not kill-job?) 
				      ;;         (eq? (vector-ref exit-info 2) 0)) ;; we can now use rollup-status instead
				      ;;         "PASS"
				      ;;         "FAIL")
582
583
584
585
586
587
588
589

590
591
592
593
594
595
596
581
582
583
584
585
586
587

588
589
590
591
592
593
594
595







-
+







							  (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
    (debug:print 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
    (open-run-close db:delete-test-step-records db test-id)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
    (open-run-close test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    (open-run-close tests:test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    (cond
     ((and launcher hosts) ;; must be using ssh hostname
      (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
     (launcher
      (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))