Megatest

Check-in [d092880d31]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added wrapper for open-run-close of db and applied to all in execute section
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | test-specific-db
Files: files | file ages | folders
SHA1: d092880d3126f62c3032268c016215e6612a8fb1
User & Date: mrwellan on 2012-09-21 15:46:59
Other Links: branch diff | manifest | tags
Context
2012-09-21
16:30
Launching code changed to open-run-close the db check-in: 784ff21f6c user: mrwellan tags: test-specific-db
15:46
Added wrapper for open-run-close of db and applied to all in execute section check-in: d092880d31 user: mrwellan tags: test-specific-db
14:38
Cleaned up most fallout from migration to test specific data file check-in: 94f8ba30bd user: mrwellan tags: test-specific-db
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified db.scm from [2653e20858] to [cfb0529798].

︙
49
50
51
52
53
54
55






56
57
58
59
60
61
62

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68








+
+
+
+
+
+








	(db:initialize db))
    ;; (if (config-lookup *configdat* "setup"     "synchronous")
    ;;     (begin
    ;;       (debug:print 4 "INFO: Turning off pragma synchronous")
    ;;       (sqlite3:execute db "PRAGMA synchronous = 0;"))
    ;;     (debug:print 4 "INFO: NOT turning off pragma synchronous"))
    db))

(define (open-run-close proc idb . params)
  (let* ((db  (if idb idb (open-db)))
	 (res (apply proc db params)))
    (if (not idb)(sqlite3:finalize! db))
    res))

(define (db:initialize db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))
︙
1024
1025
1026
1027
1028
1029
1030
1031

1032
1033
1034
1035
1036
1037
1038

1030
1031
1032
1033
1034
1035
1036

1037
1038
1039
1040
1041
1042
1043
1044








-
+








(define (db:read-test-data db test-id categorypatt)
  (let ((tdb  (db:open-test-db-by-test-id db test-id)))
    (if tdb
	(let ((res '()))
	  (sqlite3:for-each-row 
	   (lambda (id test_id category variable value expected tol units comment status type)
	     (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
	   db
	   tdb
	   "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
	  (sqlite3:finalize! tdb)
	  (reverse res))
	'())))

(define (db:load-test-data db test-id)
  (let loop ((lin (read-line)))
︙

Modified launch.scm from [908cebfd40] to [56945cc56b].

︙
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

61
62
63
64
65
66
67


68
69
70
71
72
73
74








-
-








	       (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)
	       (tdb       #f)
	       (rollup-status 0))
	  
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  ;; 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 ",")))
︙
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

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








-
+
-
-
-
-
-
+


-
-
-
-
-
+


-
+


-
-
+
+








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

	  (set! db (open-db))
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	  ;; (set! *cache-on* #t)
	  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
	  (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
	  (change-directory work-area) 

	  (on-exit (lambda ()
		     (debug:print 0 "Finalizing db!!!")
		     (sqlite3:finalize! db)))

	  (set-run-config-vars db run-id)
	  (open-run-close set-run-config-vars #f run-id)
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars db run-id)
	  (open-run-close set-megatest-env-vars #f run-id)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  (test-set-meta-info db test-id run-id test-name itemdat)
	  (test-set-status! db test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
	  (open-run-close test-set-meta-info #f test-id run-id test-name itemdat)
	  (open-run-close 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
︙
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
168
169
170

143
144
145
146
147
148
149

150



151
152
153
154
155
156
157








-
+
-
-
-








						(thread-sleep! 2)
						(loop (+ i 1)))
					      )))))
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())))
					    (db         (open-db)))
				       (if (not (args:get-arg "-server"))
					   (server:client-setup db))
				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
						      (tal    (cdr ezstepslst))
						      (prevstep #f))
︙
190
191
192
193
194
195
196
197

198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215

216
217

218
219
220
221
222
223
224

177
178
179
180
181
182
183

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201

202
203

204
205
206
207
208
209
210
211








-
+

















-
+

-
+








						   ;;       (set! script (conc script "source " prev-env))))
						   
						   ;; call the command using mt_ezstep
						   (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))

						   (debug:print 4 "script: " script)

						   (rdb:teststep-set-status! db test-id stepname "start" "-" itemdat #f #f)
						   (open-run-close db:teststep-set-status! #f test-id stepname "start" "-" itemdat #f #f)
						   ;; now launch
						   (let ((pid (process-run script)))
						     (let processloop ((i 0))
						       (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
								   (mutex-lock! m)
								   (vector-set! exit-info 0 pid)
								   (vector-set! exit-info 1 exit-status)
								   (vector-set! exit-info 2 exit-code)
								   (mutex-unlock! m)
								   (if (eq? pid-val 0)
								       (begin
									 (thread-sleep! 2)
									 (processloop (+ i 1))))
								   ))
                                                     (let ((exinfo (vector-ref exit-info 2))
                                                           (logfna (if logpro-used (conc stepname ".html") "")))
                                                        ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
						        (rdb:teststep-set-status! db test-id stepname "end" exinfo itemdat #f logfna))
						        (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna))
						     (if logpro-used
							 (rdb:test-set-log! db test-id (conc stepname ".html")))
							 (open-run-close db:test-set-log! #f test-id (conc stepname ".html")))
						     ;; set the test final status
						     (let* ((this-step-status (cond
									       ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
									       ((eq? (vector-ref exit-info 2) 0)                   'pass)
									       (else 'fail)))
							    (overall-status   (cond
									       ((eq? rollup-status 2) 'warn)
︙
232
233
234
235
236
237
238
239

240
241
242
243

244
245
246

247
248
249
250
251
252
253

219
220
221
222
223
224
225

226
227
228
229

230
231
232

233
234
235
236
237
238
239
240








-
+



-
+


-
+








						       (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
							  (test-set-status! db test-id "RUNNING" "WARN" 
							  (open-run-close test-set-status! #f test-id "RUNNING" "WARN" 
									    (if (eq? this-step-status 'warn) "Logpro warning found" #f)
									    #f))
							 ((pass)
							  (test-set-status! db test-id "RUNNING" "PASS" #f #f))
							  (open-run-close test-set-status! #f test-id "RUNNING" "PASS" #f #f))
							 (else ;; 'fail
							  (set! rollup-status 1) ;; force fail
							  (test-set-status! db test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
							  (open-run-close 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))
︙
264
265
266
267
268
269
270
271
272


273
274
275
276
277
278
279

251
252
253
254
255
256
257


258
259
260
261
262
263
264
265
266








-
-
+
+








					    ;; (diskfree (get-df (current-directory)))
					    ;; (tmpfree  (get-df "/tmp")))
				     (begin
				       ;; (if (not (args:get-arg "-server"))
				       ;;	   (server:client-setup db))
				       ;; (if (not cpuload)  (begin (debug:print 0 "WARNING: CPULOAD not found.")  (set! cpuload "n/a")))
				       ;; (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a")))
				       (set! kill-job? (test-get-kill-request db test-id)) ;; run-id test-name itemdat))
				       (test-set-meta-info db test-id run-id test-name itemdat minutes: minutes)
				       (set! kill-job? (open-run-close test-get-kill-request #f test-id)) ;; run-id test-name itemdat))
				       (open-run-close test-set-meta-info #f test-id run-id test-name itemdat minutes: minutes)
				       ;; (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree)
				       (if kill-job? 
					   (begin
					     (mutex-lock! m)
					     (let* ((pid (vector-ref exit-info 0)))
					       (if (number? pid)
						   (begin
︙
289
290
291
292
293
294
295
296

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317

318
319
320
321

322
323
324
325
326
327
328

276
277
278
279
280
281
282

283
284

285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302

303
304
305
306

307
308
309
310
311
312
313
314








-
+

-


















-
+



-
+








								(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")
						     (test-set-status! db test-id "KILLED"  "FAIL"
						     (open-run-close test-set-status! #f test-id "KILLED"  "FAIL"
								       (args:get-arg "-m") #f)
						     (sqlite3:finalize! db)
						     (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
				       (loop (calc-minutes)))))))
		 (th1          (make-thread monitorjob))
		 (th2          (make-thread runit)))
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th2)
	    (mutex-lock! m)
	    ;; (set! db (open-db))
	    ;; (if (not (args:get-arg "-server"))
	    ;;	(server:client-setup db))
	    (let* ((item-path (item-list->path itemdat))
		   (testinfo  (db:get-test-info-by-id db test-id))) ;; )) ;; run-id test-name item-path)))
		   (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)
		    (test-set-status! db test-id 
		    (open-run-close 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")
︙
337
338
339
340
341
342
343
344

345
346
347
348
349
350
351

323
324
325
326
327
328
329

330
331
332
333
334
335
336
337








-
+








				       ((eq? rollup-status 2)
					;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
					(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
				       (else "FAIL"))
				      (args:get-arg "-m") #f)))
	      ;; for automated creation of the rollup html file this is a good place...
	      (if (not (equal? item-path ""))
		  (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no
		  (open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no
	      )
	    (mutex-unlock! m)
	    ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
	    ;; (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)
︙

Modified runs.scm from [60fd9683ee] to [d1cf09ce49].

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

59
60
61
62
63
64
65

66
67
68
69
70
71
72








-








     runnamepatt)
    (vector header res)))

(define (runs:test-get-full-path test)
  (let* ((testname (db:test-get-testname   test))
	 (itempath (db:test-get-item-path test)))
    (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))


(define (set-megatest-env-vars db run-id)
  (let ((keys (rdb:get-keys db)))
    (for-each (lambda (key)
		(sqlite3:for-each-row
		 (lambda (val)
		   (debug:print 2 "setenv " (key:get-fieldname key) " " val)
︙

Modified tests/tests.scm from [fdee90c537] to [403df89532].

︙
52
53
54
55
56
57
58




59
60
61
62
63
64
65

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69








+
+
+
+









(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))

(test "register-test, test info" "NOT_STARTED"
      (begin
	(tests:register-test *db* 1 "nada" "")
	(vector-ref (db:get-test-info *db* 1 "nada" "") 3)))
(test #f "NOT_STARTED"    
      (begin
	(open-run-close tests:register-test #f 1 "nada" "")
	(vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)))

(test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0)))))))

(define remargs (args:get-args
		 '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada")
		 (list ":runname" ":state" ":status")
		 (list "-h")
︙

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