Megatest

Check-in [cc1b5a10b2]
Login
Overview
Comment:Refactored more db stuff to use open-run-close
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | test-specific-db | v1.4605
Files: files | file ages | folders
SHA1: cc1b5a10b28b8fc51a996dd2bb24cba024bef03a
User & Date: mrwellan on 2012-09-28 16:23:54
Other Links: branch diff | manifest | tags
Context
2012-09-28
18:28
Bumped jobs to 200 check-in: cf1e5bff8c user: matt tags: test-specific-db, v1.4606
16:23
Refactored more db stuff to use open-run-close check-in: cc1b5a10b2 user: mrwellan tags: test-specific-db, v1.4605
12:01
Fixed the MT_RUN_AREA_HOME, previous fix did not set the var before parsing .config files. check-in: 67e15ae474 user: mrwellan tags: test-specific-db, v1.4604
Changes

Modified db.scm from [8c6e608c5e] to [a162544976].

64
65
66
67
68
69
70

71
72
73
74
75
76
77
78
79
80
81
82


83
84
85
86



87
88
89
90
91
92
93
64
65
66
67
68
69
70
71
72
73
74

75
76
77
78
79
80


81
82




83
84
85
86
87
88
89
90
91
92







+



-






-
-
+
+
-
-
-
-
+
+
+







    (debug:print 4 "INFO: dbpath=" dbpath)
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(db:initialize db))
    (db:set-sync db)
    db))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
 (let* ((db   (if idb idb (open-db)))
	(res #f))
   (db:set-sync db)
   (set! res (apply proc db params))
   (if (not idb)(sqlite3:finalize! db))
   res))

(define (open-run-close-exception-handling proc idb . params)
 (let ((runner (lambda ()
    	  (let* ((db   (if idb idb (open-db)))
    		 (res #f))
		 (let* ((db   (if idb idb (open-db)))
			(res #f))
    	    (db:set-sync db)
    	    (set! res (apply proc db params))
    	    (if (not idb)(sqlite3:finalize! db))
    	    res))))
		   (set! res (apply proc db params))
		   (if (not idb)(sqlite3:finalize! db))
		   res))))
   (handle-exceptions
    exn
    (begin
      (debug:print 0 "EXCEPTION: database probably overloaded?")
      (debug:print 0 "  " exn)
      (print-call-chain)
      (thread-sleep! (random 120))

Modified launch.scm from [1d93c92f83] to [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))))

Modified megatest.scm from [3ee9ed6771] to [f47e8f14e8].

224
225
226
227
228
229
230
231

232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264


265
266
267
268
269
270
271


272
273
274
275
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
224
225
226
227
228
229
230

231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

248

249
250
251
252
253
254

255
256
257
258
259
260


261
262
263
264
265
266
267


268
269
270
271
272
273
274
275
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







-
+
















-
+
-






-






-
-
+
+





-
-
+
+



















+
+










-
-
+
+








;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on db action)
(define (operate-on action)
  (cond
   ((not (args:get-arg ":runname"))
    (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt")
    (exit 2))
   ((not (args:get-arg "-testpatt"))
    (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt")
    (exit 3))
   ((not (args:get-arg "-itempatt"))
    (print "ERROR: Missing required parameter for " action ", you must specify the items with -itempatt")
    (exit 4))
   (else
    (if (not (car *configinfo*))
	(begin
	  (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found")
	  (exit 1))
	;; put test parameters into convenient variables
	(runs:operate-on  db
	(runs:operate-on  action
			  action
			  (args:get-arg ":runname")
			  (args:get-arg "-testpatt")
			  (args:get-arg "-itempatt")
			  state: (args:get-arg ":state") 
			  status: (args:get-arg ":status")
			  new-state-status: (args:get-arg "-set-state-status")))
    (sqlite3:finalize! db)
    (set! *didsomething* #t))))
	  
(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"
     (lambda (db target runname keys keynames keyvallst)
       (operate-on db 'remove-runs))))
     (lambda (target runname keys keynames keyvallst)
       (operate-on 'remove-runs))))

(if (args:get-arg "-set-state-status")
    (general-run-call 
     "-set-state-status"
     "set state and status"
     (lambda (db target runname keys keynames keyvallst)
       (operate-on db 'set-state-status))))
     (lambda (target runname keys keynames keyvallst)
       (operate-on 'set-state-status))))

;;======================================================================
;; Query runs
;;======================================================================

(if (args:get-arg "-list-runs")
    (let* ((db       (begin
		       (setup-for-run)
		       (open-db)))
	   (runpatt  (args:get-arg "-list-runs"))
	   (testpatt (args:get-arg "-testpatt"))
	   (itempatt (args:get-arg "-itempatt"))
	   (runsdat  (db:get-runs db runpatt #f #f '()))
	   (runs     (db:get-rows runsdat))
	   (header   (db:get-header runsdat))
	   (keys     (db:get-keys db))
	   (keynames (map key:get-fieldname keys)))
      (if (not (args:get-arg "-server"))
	  (server:client-setup db))
      (sqlite3:finalize! db)
      (set! db #f)
      ;; Each run
      (for-each 
       (lambda (run)
	 (debug:print 1 "Run: "
		(string-intersperse (map (lambda (x)
					   (db:get-value-by-header run header x))
					 keynames) "/")
		"/"
		(db:get-value-by-header run header "runname")
		" status: " (db:get-value-by-header run header "state"))
	 (let ((run-id (db:get-value-by-header run header "id")))
	   (let ((tests (db:get-tests-for-run db run-id testpatt itempatt '() '())))
	 (let ((run-id (open-run-close db:get-value-by-header run header "id")))
	   (let ((tests (open-run-close db:get-tests-for-run db run-id testpatt itempatt '() '())))
	     ;; Each test
	     (for-each 
	      (lambda (test)
		(format #t
			"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
			(conc (db:test-get-testname test)
			      (if (equal? (db:test-get-item-path test) "")
320
321
322
323
324
325
326
327

328
329
330
331
332
333
334
320
321
322
323
324
325
326

327
328
329
330
331
332
333
334







-
+







		    (begin
		      (print "         cpuload:  " (db:test-get-cpuload test)
			     "\n         diskfree: " (db:test-get-diskfree test)
			     "\n         uname:    " (db:test-get-uname test)
			     "\n         rundir:   " (db:test-get-rundir test)
			     )
		      ;; Each test
		      (let ((steps (db:get-steps-for-test db (db:test-get-id test))))
		      (let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test))))
			(for-each 
			 (lambda (step)
			   (format #t 
				   "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
				   (db:step-get-stepname step)
				   (db:step-get-state step)
				   (db:step-get-status step)
376
377
378
379
380
381
382
383

384
385
386
387
388

389
390
391
392
393
394
395
396
376
377
378
379
380
381
382

383
384
385
386
387

388

389
390
391
392
393
394
395







-
+




-
+
-







;;   process deferred tasks per above steps

;; run all tests are are Not COMPLETED and PASS or CHECK
(if (args:get-arg "-runall")
    (general-run-call 
     "-runall"
     "run all tests"
     (lambda (db target runname keys keynames keyvallst)
     (lambda (target runname keys keynames keyvallst)
;;       (let ((flags (make-hash-table)))
;;	 (for-each (lambda (parm)
;;		     (hash-table-set! flags parm (args:get-arg parm)))
;;		   (list "-rerun" "-force" "-itempatt"))
	 (runs:run-tests db
	 (runs:run-tests target
			 target
			 runname
			 (args:get-arg "-runtests")
			 user
			 args:arg-hash)))) ;; )

;;======================================================================
;; run one test
409
410
411
412
413
414
415
416
417


418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433


434
435
436
437
438
439
440
441
442
443
444
445
446
447
448


449
450
451
452
453
454
455
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
433
434
435
436
437
438
439
440
441
442
443


444
445
446
447
448
449
450
451
452







-
-
+
+
-













-
-
+
+
-












-
-
+
+







;;    - if test run time > allowed run time then kill job
;;    - if cannot access db > allowed disconnect time then kill job

(if (args:get-arg "-runtests")
  (general-run-call 
   "-runtests" 
   "run a test" 
   (lambda (db target runname keys keynames keyvallst)
     (runs:run-tests db
   (lambda (target runname keys keynames keyvallst)
     (runs:run-tests target
		     target
		     runname
		     (args:get-arg "-runtests")
		     user
		     args:arg-hash))))

;;======================================================================
;; Rollup into a run
;;======================================================================

(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 
     "rollup tests" 
     (lambda (db target runname keys keynames keyvallst)
       (runs:rollup-run db
     (lambda (target runname keys keynames keyvallst)
       (runs:rollup-run keys
			keys
			(keys->alist keys "na")
			(args:get-arg ":runname") 
			user))))

;;======================================================================
;; Lock or unlock a run
;;======================================================================

(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
    (general-run-call 
     (if (args:get-arg "-lock") "-lock" "-unlock")
     "lock/unlock tests" 
     (lambda (db target runname keys keynames keyvallst)
       (runs:handle-locking db
     (lambda (target runname keys keynames keyvallst)
       (runs:handle-locking 
		  target
		  keys
		  (args:get-arg ":runname") 
		  (args:get-arg "-lock")
		  (args:get-arg "-unlock")
		  user))))

480
481
482
483
484
485
486
487




488
489

490
491

492
493
494
495
496
497
498
499
500
501
502




503
504
505
506
507
508
509
477
478
479
480
481
482
483

484
485
486
487
488

489
490

491
492
493
494
495
496
497
498
499



500
501
502
503
504
505
506
507
508
509
510







-
+
+
+
+

-
+

-
+








-
-
-
+
+
+
+







		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (set! db (open-db))    
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	      (server:client-setup db)
	      (begin
		(sqlite3:finalize! db)
		(set! db #f)))
	  (let* ((itempatt (args:get-arg "-itempatt"))
		 (keys     (db:get-keys db))
		 (keys     (open-run-close db:get-keys db))
		 (keynames (map key:get-fieldname keys))
		 (paths    (db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
		 (paths    (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(print path))
		      paths)))
	;; else do a general-run-call
	(general-run-call 
	 "-test-files"
	 "Get paths to test"
	 (lambda (db target runname keys keynames keyvallst)
	   (let* ((itempatt (args:get-arg "-itempatt"))
		  (paths    (db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
	 (lambda (target runname keys keynames keyvallst)
	   (let* ((db       #f)
		  (itempatt (args:get-arg "-itempatt"))
		  (paths    (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Archive tests
;;======================================================================
528
529
530
531
532
533
534
535
536
537
538
539

540
541

542
543
544
545
546
547
548
549
550
551
552




553
554
555
556
557
558
559
560
561
562
563
564
565
566



567
568
569
570
571

572
573
574
575
576
577
578
529
530
531
532
533
534
535



536

537
538

539
540
541
542
543
544
545
546
547



548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563


564
565
566
567
568
569
570

571
572
573
574
575
576
577
578







-
-
-

-
+

-
+








-
-
-
+
+
+
+












-
-
+
+
+




-
+







	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")
		(exit 1)))
	  (set! db (open-db))   
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	  (let* ((itempatt (args:get-arg "-itempatt"))
		 (keys     (db:get-keys db))
		 (keys     (open-run-close db:get-keys db))
		 (keynames (map key:get-fieldname keys))
		 (paths    (db:test-get-paths-matching db keynames target)))
		 (paths    (open-run-close db:test-get-paths-matching db keynames target)))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(print path))
		      paths)))
	;; else do a general-run-call
	(general-run-call 
	 "-test-paths"
	 "Get paths to tests"
	 (lambda (db target runname keys keynames keyvallst)
	   (let* ((itempatt (args:get-arg "-itempatt"))
		  (paths    (db:test-get-paths-matching db keynames target)))
	 (lambda (target runname keys keynames keyvallst)
	   (let* ((db       #f)
		  (itempatt (args:get-arg "-itempatt"))
		  (paths    (open-run-close db:test-get-paths-matching db keynames target)))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call
     "-extract-ods"
     "Make ods spreadsheet"
     (lambda (db target runname keys keynames keyvallst)
       (let ((outputfile (args:get-arg "-extract-ods"))
     (lambda (target runname keys keynames keyvallst)
       (let ((db         #f)
	     (outputfile (args:get-arg "-extract-ods"))
	     (runspatt   (args:get-arg ":runname"))
	     (pathmod    (args:get-arg "-pathmod"))
	     (keyvalalist (keys->alist keys "%")))
	 (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist)
	 (db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod)))))
	 (open-run-close db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod)))))

;;======================================================================
;; execute the test
;;    - gets called on remote host
;;    - receives info from the -execute param
;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;    - gathers host info and 
608
609
610
611
612
613
614
615




616
617

618
619
620
621

622
623
624
625
626
627
628
608
609
610
611
612
613
614

615
616
617
618
619

620
621
622
623

624
625
626
627
628
629
630
631







-
+
+
+
+

-
+



-
+







	  (change-directory testpath)
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))
	  (set! db (open-db))
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	      (server:client-setup db)
	      (begin
		(sqlite3:finalize! db)
		(set! db #f)))
	  (if (and state status)
	      (db:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile)
	      (open-run-close db:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile)
	      (begin
		(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
		(exit 6)))
	  (sqlite3:finalize! db)
	  (if db (sqlite3:finalize! db))
	  (set! *didsomething* #t))))

(if (or (args:get-arg "-setlog")       ;; since setting up is so costly lets piggyback on -test-status
	(args:get-arg "-set-toplog")
	(args:get-arg "-test-status")
	(args:get-arg "-set-values")
	(args:get-arg "-load-test-data")
647
648
649
650
651
652
653
654




655
656
657

658
659
660

661
662

663
664

665
666
667
668
669

670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686

687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709

710
711

712
713
714
715
716
717

718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738

739
740
741
742


743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759





760
761

762
763
764
765
766
767
768
650
651
652
653
654
655
656

657
658
659
660
661
662

663
664
665

666
667

668
669

670
671
672
673
674

675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691

692


693
694
695
696
697
698




699
700
701
702
703
704
705
706
707
708

709
710

711






712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732

733
734
735


736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752


753
754
755
756
757
758

759
760
761
762
763
764
765
766







-
+
+
+
+


-
+


-
+

-
+

-
+




-
+
















-
+
-
-






-
-
-
-










-
+

-
+
-
-
-
-
-
-
+




















-
+


-
-
+
+















-
-
+
+
+
+
+

-
+







	  (change-directory testpath)
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))
	  (set! db (open-db))
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	      (server:client-setup db)
	      (begin
		(sqlite3:finalize! db)
		(set! db #f)))
	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      (db:load-test-data db test-id))
	      (open-run-close db:load-test-data db test-id))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))
		(db:test-set-log! db test-id logfname)))
		(open-run-close db:test-set-log! db test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      (rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	      (open-run-close tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      (tests:summarize-items db run-id test-name #t)) ;; do force here
	      (open-run-close tests:summarize-items db run-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (sqlite3:finalize! db)
		    (if db (sqlite3:finalize! db))
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
			 (logprofile (args:get-arg "-logpro"))
			 (logfile    (conc stepname ".log"))
			 (cmd        (if (null? remargs) #f (car remargs)))
			 (params     (if cmd (cdr remargs) '()))
			 (exitstat   #f)
			 (shell      (last (string-split (get-environment-variable "SHELL") "/")))
			 (redir      (case (string->symbol shell)
				       ((tcsh csh ksh)    ">&")
				       ((zsh bash sh ash) "2>&1 >")
				       (else ">&")))
			 (fullcmd    (conc "(" (string-intersperse 
						(cons cmd params) " ")
					   ") " redir " " logfile)))
		    ;; mark the start of the test
		    (db:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile)
		    (open-run-close db:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile)
		    ;; close the db
		    ;; (sqlite3:finalize! db)
		    ;; run the test step
		    (debug:print 2 "INFO: Running \"" fullcmd "\"")
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd)) ;; cmd params))
		    (set! *globalexitstatus* exitstat)
		    (change-directory testpath)
		    ;; re-open the db
		    ;; (set! db (open-db))
		    ;; (if (not (args:get-arg "-server"))
		    ;;     (server:client-setup db))
		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
		    (if logprofile
			(let* ((htmllogfile (conc stepname ".html"))
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (debug:print 2 "INFO: running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (db:test-set-log! db test-id htmllogfile)))
			  (open-run-close db:test-set-log! db test-id htmllogfile)))
		    (let ((msg (args:get-arg "-m")))
		      (db:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile))
		      (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile))
		    ;; (sqlite3:finalize! db)
		    ;;(if (not (eq? exitstat 0))
		    ;;	(exit 254)) ;; (exit exitstat) doesn't work?!?
		  ;; open the db
		  ;; mark the end of the test
		  )))
		    )))
	  (if (or (args:get-arg "-test-status")
		  (args:get-arg "-set-values"))
	      (let ((newstatus (cond
				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
				((and (string? status)
				      (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
				(else status)))
		    ;; transfer relevant keys into a hash to be passed to test-set-status!
		    ;; could use an assoc list I guess. 
		    (otherdata (let ((res (make-hash-table)))
				 (for-each (lambda (key)
					     (if (args:get-arg key)
						 (hash-table-set! res key (args:get-arg key))))
					   (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
				 res)))
		(if (and (args:get-arg "-test-status")
			 (or (not state)
			     (not status)))
		    (begin
		      (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
		      (sqlite3:finalize! db)
		      ;; (sqlite3:finalize! db)
		      (exit 6)))
		(let ((msg (args:get-arg "-m")))
		  (rtests:test-set-status! db test-id state newstatus msg otherdata))))
	  (sqlite3:finalize! db)
		  (open-run-close tests:test-set-status! db test-id state newstatus msg otherdata))))
	  (if db (sqlite3:finalize! db))
	  (set! *didsomething* #t))))

;;======================================================================
;; Various helper commands can go below here
;;======================================================================

(if (args:get-arg "-showkeys")
    (let ((db #f)
	  (keys #f))
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! db (open-db))
      (if (not (args:get-arg "-server"))
	  (server:client-setup db))
      (set! keys (db:get-keys db))
	  (server:client-setup db)
	  (begin
	    (sqlite3:finalize! db)
	    (set! db #f)))
      (set! keys (open-run-close db:get-keys db))
      (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
      (sqlite3:finalize! db)
      (if db (sqlite3:finalize! db))
      (set! *didsomething* #t)))

(if (args:get-arg "-gui")
    (begin
      (debug:print 0 "Look at the dashboard for now")
      ;; (megatest-gui)
      (set! *didsomething* #t)))
783
784
785
786
787
788
789
790
791
792

793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811






812
813
814
815
816
817
818
781
782
783
784
785
786
787



788

789
790
791
792
793
794
795
796
797
798
799
800
801
802
803



804
805
806
807
808
809
810
811
812
813
814
815
816







-
-
-
+
-















-
-
-
+
+
+
+
+
+








(if (args:get-arg "-rebuild-db")
    (begin
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; now can find our db
      (set! db (open-db))
      (patch-db db)
      (open-run-close patch-db #f)
      (sqlite3:finalize! db)
      (set! *didsomething* #t)))

;;======================================================================
;; Update the tests meta data from the testconfig files
;;======================================================================

(if (args:get-arg "-update-meta")
    (begin
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; now can find our db
      (set! db (open-db))
      (if (not (args:get-arg "-server"))
	  (server:client-setup db))
      (runs:update-all-test_meta db)
      (sqlite3:finalize! db)
	  (server:client-setup db)
	  (begin
	    (sqlite3:finalize! db)
	    (set! db #f)))
      (open-run-close runs:update-all-test_meta db)
      (if db (sqlite3:finalize! db))
      (set! *didsomething* #t)))

;;======================================================================
;; Start a repl
;;======================================================================

(if (args:get-arg "-repl")

Modified runs.scm from [32036156e7] to [e8b32cf957].

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







-
-
+
+
+

-
+








-
+


-
+







	  res) 
	(begin
	  (debug:print 0 "ERROR: Called without all necessary keys")
	  #f))))

;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals
(define (runs:run-tests db target runname test-patts user flags)
  (let* ((keys        (db:get-keys db))
(define (runs:run-tests target runname test-patts user flags)
  (let* ((db          #f)
	 (keys        (open-run-close db:get-keys db))
	 (keyvallst   (keys:target->keyval keys target))
	 (run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (run-id      (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 ;; keepgoing is the defacto modality now, will add hit-n-run a bit later
	 ;; (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
	 (test-names  '())
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '())
	 (test-records (make-hash-table)))

    (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
    (open-run-close 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* "pre-launch-env-vars")
	(open-run-close 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 "%" "*")))))
222
223
224
225
226
227
228
229
230


231
232
233

234
235
236
237
238
239
240
241
242
243
244

245
246
247
248
249
250
251
223
224
225
226
227
228
229


230
231
232
233

234
235
236
237
238
239
240
241
242
243
244

245
246
247
248
249
250
251
252







-
-
+
+


-
+










-
+







    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(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 
	  ;; on test A but test B reached the point on being registered as NOT_STARTED and test
	  ;; A failed for some reason then on re-run using -keepgoing the run can never complete.
	  (db:delete-tests-in-state db run-id "NOT_STARTED")
	  (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
	  (open-run-close db:delete-tests-in-state db run-id "NOT_STARTED")
	  (open-run-close db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))

    ;; from here on out the db will be opened and closed on every call runs:run-tests-queue
    (sqlite3:finalize! db) 
    ;; (sqlite3:finalize! db) 
    ;; now add non-directly referenced dependencies (i.e. waiton)
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	  (debug:print 4 "INFO: hed=" hed " at top of loop")
	  (let* ((config  (tests:get-testconfig hed 'return-procs))
		 (waitons (if config (string-split (let ((w (config-lookup config "requirements" "waiton")))
						     (if w w "")))
			      (begin
				(debug:print 0 "ERROR: non-existent required test \"" hed "\"")
                                (sqlite3:finalize! db)
                                (if db (sqlite3:finalize! db))
				(exit 1)))))
	    ;; check for hed in waitons => this would be circular, remove it and issue an
	    ;; error
	    (if (member hed waitons)
		(begin
		  (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		  (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
652
653
654
655
656
657
658
659

660
661
662
663
664
665
666
653
654
655
656
657
658
659

660
661
662
663
664
665
666
667







-
+







	 (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
	((LAUNCHED REMOTEHOSTSTART RUNNING)  
	 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
				       (db:test-get-run_duration testdat)))
		600) ;; i.e. no update for more than 600 seconds
	     (begin
	       (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
	       (open-run-close test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
	       (open-run-close tests:test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
	     (debug:print 2 "NOTE: " test-name " is already running")))
	(else       (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))))

;;======================================================================
;; END OF NEW STUFF
;;======================================================================

674
675
676
677
678
679
680
681
682
683




684
685
686
687
688
689
690
691
692
693
694
695
696
697
698

699
700
701
702
703
704
705
675
676
677
678
679
680
681



682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699

700
701
702
703
704
705
706
707







-
-
-
+
+
+
+














-
+







;; fields are passing in through 
;; action:
;;    'remove-runs
;;    'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on db action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-status #f))
  (let* ((keys         (db:get-keys db))
	 (rundat       (runs:get-runs-by-patt db keys runnamepatt))
(define (runs:operate-on action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-status #f))
  (let* ((db           #f)
	 (keys         (open-run-close db:get-keys db))
	 (rundat       (open-run-close runs:get-runs-by-patt db keys runnamepatt))
	 (header       (vector-ref rundat 0))
	 (runs         (vector-ref rundat 1))
	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
    (debug:print 2 "Header: " header " action: " action " new-state-status: " new-state-status)
    (for-each
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
	     (dirs-to-remove (make-hash-table)))
	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))
		(tests     (if (not (equal? run-state "locked"))
			       (db:get-tests-for-run db (db:get-value-by-header run header "id")
			       (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id")
						      testpatt itempatt states statuses
						      not-in:  #f
						      sort-by: (case action
								 ((remove-runs) 'rundir)
								 (else          'event_time)))
			       '()))
		(lasttpath "/does/not/exist/I/hope"))
719
720
721
722
723
724
725
726

727
728
729
730
731
732
733
721
722
723
724
725
726
727

728
729
730
731
732
733
734
735







-
+







			   (test-name (db:test-get-testname test))
			   (run-dir   (db:test-get-rundir test))
			   (test-id   (db:test-get-id test)))
		      ;;   (tdb       (db:open-test-db run-dir)))
		      (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action)
		      (case action
			((remove-runs) ;; the tdb is for future possible. 
			 (db:delete-test-records db #f (db:test-get-id test))
			 (open-run-close db:delete-test-records db #f (db:test-get-id test))
			 (debug:print 1 "INFO: Attempting to remove dir " run-dir)
			 (if (and (> (string-length run-dir) 5)
				  (file-exists? run-dir)) ;; bad heuristic but should prevent /tmp /home etc.
			     (let* ((realpath (resolve-pathname run-dir)))
			       (debug:print 1 "INFO: Real path of is " realpath)
			       (if (file-exists? realpath)
				   (if (> (system (conc "rm -rf " realpath)) 0)
746
747
748
749
750
751
752
753

754
755
756
757
758
759
760

761
762
763
764



765
766
767
768
769
770
771
748
749
750
751
752
753
754

755
756
757
758
759
760
761

762
763



764
765
766
767
768
769
770
771
772
773







-
+






-
+

-
-
-
+
+
+







			((set-state-status)
			 (debug:print 2 "INFO: new state " (car state-status) ", new status " (cadr state-status))
			 (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)))))
		  tests)))
	   
	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let ((remtests (db:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '("DELETED") '("n/a") not-in: #t)))
	       (let ((remtests (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))
						"/"))))
		       (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
		       (db:delete-run db run-id)
		       (open-run-close db:delete-run db run-id)
		       ;; This is a pretty good place to purge old DELETED tests
		       (db:delete-tests-for-run db run-id)
		       (db:delete-old-deleted-test-records db)
		       (db:set-var db "DELETED_TESTS" (current-seconds))
		       (open-run-close db:delete-tests-for-run db run-id)
		       (open-run-close db:delete-old-deleted-test-records db)
		       (open-run-close db:set-var db "DELETED_TESTS" (current-seconds))
		       ;; need to figure out the path to the run dir and remove it if empty
		       ;;    (if (null? (glob (conc runpath "/*")))
		       ;;        (begin
		       ;; 	 (debug:print 1 "Removing run dir " runpath)
		       ;; 	 (system (conc "rmdir -p " runpath))))
		       )))))
	 ))
796
797
798
799
800
801
802
803
804
805
806







807
808
809
810
811
812
813
814
815

816
817
818
819
820
821
822
823
824
825
826
827

828
829

830
831
832
833
834
835
836
837



838
839
840
841
842
843
844
845
846
847

848
849
850
851
852
853
854
855
856

857
858
859
860

861
862
863
864
865
866
867
868
869
870

871
872
873
874
875
876
877
878
879
880
881
882

883

884
885
886
887

888
889
890
891
892




893
894

895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912

913
914
915
916
917
918
919
920

921
922
923


924
925
926
927
928
929
930
931
932
933
934
935












936
937
938
939
798
799
800
801
802
803
804




805
806
807
808
809
810
811
812
813
814
815
816
817
818
819

820
821
822
823
824
825
826
827
828
829
830
831

832
833

834
835
836
837
838
839
840


841
842
843
844
845
846
847
848
849
850
851
852

853
854
855
856
857
858
859
860
861

862
863
864
865

866
867
868
869
870
871
872
873
874
875

876
877
878
879
880
881
882
883
884
885
886
887
888
889

890
891
892
893

894
895




896
897
898
899
900

901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918

919
920
921
922
923
924
925
926

927
928
929
930
931
932












933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948







-
-
-
-
+
+
+
+
+
+
+








-
+











-
+

-
+






-
-
+
+
+









-
+








-
+



-
+









-
+












+
-
+



-
+

-
-
-
-
+
+
+
+

-
+

















-
+







-
+



+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+




	(if (not (setup-for-run))
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db   (open-db))
	(if (args:get-arg "-server")
	    (server:start db (args:get-arg "-server"))
	    (if (not (or (args:get-arg "-runall")
			  (args:get-arg "-runtests")))
		(server:client-setup db)))
	(set! keys (db:get-keys db))
	    (if (not (or (args:get-arg "-runall")     ;; runall and runtests are allowed to be servers
			 (args:get-arg "-runtests")))
		(server:client-setup db)
		(begin
		  (sqlite3:finalize! db)
		  (set! db #f))))
	(set! keys (open-run-close db:get-keys db))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (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)
		    (if db (sqlite3:finalize! db))
		    (exit 1))))
	    (if (args:get-arg "-target")
		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
	(if (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keynames   (map key:get-fieldname keys))
		   (keyvallst  (keys->vallist keys #t)))
	      (proc db target runname keys keynames keyvallst)))
	      (proc target runname keys keynames keyvallst)))
	(if th1 (thread-join! th1))
	(sqlite3:finalize! db)
	(if db (sqlite3:finalize! db))
	(set! *didsomething* #t))))))

;;======================================================================
;; Lock/unlock runs
;;======================================================================

(define (runs:handle-locking db target keys runname lock unlock user)
  (let* ((rundat   (runs:get-runs-by-patt db keys runname))
(define (runs:handle-locking target keys runname lock unlock user)
  (let* ((db       #f)
	 (rundat   (open-run-close runs:get-runs-by-patt db keys runname))
	 (header   (vector-ref rundat 0))
	 (runs     (vector-ref rundat 1)))
    (for-each (lambda (run)
		(let ((run-id (db:get-value-by-header run header "id")))
		  (if (or lock
			  (and unlock
			       (begin
				 (print "Do you really wish to unlock run " run-id "?\n   y/n: ")
				 (equal? "y" (read-line)))))
		      (db:lock/unlock-run db run-id lock unlock user)
		      (open-run-close db:lock/unlock-run db run-id lock unlock user)
		      (debug:print 0 "INFO: Skipping lock/unlock on " run-id))))
	      runs)))
;;======================================================================
;; Rollup runs
;;======================================================================

;; Update the test_meta table for this test
(define (runs:update-test_meta db test-name test-conf)
  (let ((currrecord (db:testmeta-get-record db test-name)))
  (let ((currrecord (open-run-close db:testmeta-get-record db test-name)))
    (if (not currrecord)
	(begin
	  (set! currrecord (make-vector 10 #f))
	  (db:testmeta-add-record db test-name)))
	  (open-run-close db:testmeta-add-record db test-name)))
    (for-each 
     (lambda (key)
       (let* ((idx (cadr key))
	      (fld (car  key))
	      (val (config-lookup test-conf "test_meta" fld)))
	 ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
	 (if (and val (not (equal? (vector-ref currrecord idx) val)))
	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (db:testmeta-update-field db test-name fld val)))))
	       (open-run-close db:testmeta-update-field db test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (get-all-legal-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-path    (conc *toppath* "/tests/" test-name))
	      (test-configf (conc test-path "/testconfig"))
	      (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	      ;; read configs with tricks turned off (i.e. no system)
	      (test-conf    (if testexists (read-config test-configf #f #f)(make-hash-table))))
	 ;; use the open-run-close instead of passing in db
	 (runs:update-test_meta db test-name test-conf)))
	 (runs:update-test_meta #f test-name test-conf)))
     test-names)))

;; This could probably be refactored into one complex query ...
(define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst
(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst
  (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
  (let* (; (keyvalllst      (keys:target->keyval keys target))
	 (new-run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))
	 (prev-tests      (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (db:get-tests-for-run db new-run-id "%" "%" '() '()))
  (let* ((db              #f) ;; (keyvalllst      (keys:target->keyval keys target))
	 (new-run-id      (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user))
	 (prev-tests      (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (open-run-close db:get-tests-for-run db new-run-id "%" "%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (db:update-run-event_time db new-run-id)
    (open-run-close db:update-run-event_time db new-run-id)
    ;; index the already saved tests by testname and itemdat in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
	 (hash-table-set! curr-tests-hash full-name testdat)))
     curr-tests)
    ;; NOPE: Non-optimal approach. Try this instead.
    ;;   1. tests are received in a list, most recent first
    ;;   2. replace the rollup test with the new *always*
    (for-each 
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path))
	      (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
	      (test-steps      (db:get-steps-for-test db (db:test-get-id testdat)))
	      (test-steps      (open-run-close db:get-steps-for-test db (db:test-get-id testdat)))
	      (new-test-record #f))
	 ;; replace these with insert ... select
	 (apply sqlite3:execute 
		db 
		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
		new-run-id (cddr (vector->list testdat)))
	 (set! new-testdat (car (db:get-tests-for-run db new-run-id testname item-path '() '())))
	 (set! new-testdat (car (open-run-close db:get-tests-for-run db new-run-id testname item-path '() '())))
	 (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table?
	 ;; Now duplicate the test steps
	 (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
	 (open-run-close 
	  (lambda ()
	 (sqlite3:execute 
	  db 
	  (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) "
		"SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;")
	  (db:test-get-id testdat))
	 ;; Now duplicate the test data
	 (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
	 (sqlite3:execute 
	  db 
	  (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) "
		"SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
	  (db:test-get-id testdat))
	    (sqlite3:execute 
	     db 
	     (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) "
		   "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;")
	     (db:test-get-id testdat))
	    ;; Now duplicate the test data
	    (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
	    (sqlite3:execute 
	     db 
	     (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) "
		   "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
	     (db:test-get-id testdat))))
	 ))
     prev-tests)))
	 
     

Modified tests.scm from [b33efa2b90] to [015515b8a1].

109
110
111
112
113
114
115
116

117
118
119
120
121
122
123
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123







-
+







			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

;; 
(define (test-set-status! db test-id state status comment dat)
(define (tests:test-set-status! db test-id state status comment dat)
  (let* ((real-status status)
	 (otherdat    (if dat dat (make-hash-table)))
	 (testdat     (db:get-test-info-by-id db test-id))
	 (run-id      (db:test-get-run_id testdat))
	 (test-name   (db:test-get-testname   testdat))
	 (item-path   (db:test-get-item-path testdat))
	 ;; before proceeding we must find out if the previous test (where all keys matched except runname)
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202







-
+







    (if (or (and (string? comment)
		 (string-match (regexp "\\S+") comment))
	    waived)
	(let ((cmt  (if waived waived comment)))
	  (db:test-set-comment db test-id cmt)))
    ))

(define (test-set-toplog! db run-id test-name logf) 
(define (tests:test-set-toplog! db run-id test-name logf) 
  (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" 
		   logf run-id test-name))

(define (tests:summarize-items db run-id test-name force)
  ;; if not force then only update the record if one of these is true:
  ;;   1. logf is "log/final.log
  ;;   2. logf is same as outputfilename
273
274
275
276
277
278
279
280

281
282
283
284
285
286
287
273
274
275
276
277
278
279

280
281
282
283
284
285
286
287







-
+








		(print "<table cellspacing=\"0\" border=\"1\">" 
		       "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
		       outtxt "</table></body></html>")
		(release-dot-lock outputfilename)))
	    (close-output-port oup)
	    (change-directory orig-dir)
	    (test-set-toplog! db run-id test-name outputfilename)
	    (tests:test-set-toplog! db run-id test-name outputfilename)
	    )))))

(define (get-all-legal-tests)
  (let* ((tests  (glob (conc *toppath* "/tests/*")))
	 (res    '()))
    (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
    (for-each (lambda (testpath)
451
452
453
454
455
456
457
458

459
460
461
462
463
464
465

466
451
452
453
454
455
456
457

458
459
460
461
462
463
464

465
466







-
+






-
+

      (tests:register-test db run-id test-name item-path)))

(define (rtests:test-set-status!  db test-id state status comment dat)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rtests:test-set-status! host port) test-id state status comment dat))
      (test-set-status! db test-id state status comment dat)))
      (tests:test-set-status! db test-id state status comment dat)))

(define (rtests:test-set-toplog! db run-id test-name logf)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
            (port (vector-ref *runremote* 1)))
        ((rpc:procedure 'rtests:test-set-toplog! host port) run-id test-name logf))
      (test-set-toplog! db run-id test-name logf)))
      (tests:test-set-toplog! db run-id test-name logf)))

Modified tests/fullrun/config/mt_include_1.config from [a426d87ac1] to [ba3dc8955e].

1
2
3

4
5
6
7
8
9
10
1
2

3
4
5
6
7
8
9
10


-
+







[setup]
# exectutable /path/to/megatest
max_concurrent_jobs 50
max_concurrent_jobs 25
linktree /tmp/mt_links

[jobtools]
useshell yes
# ## launcher launches jobs, the job is managed on the target host
## by megatest, comment out launcher to run local
# workhosts localhost hermes