Megatest

Check-in [3aeabde95d]
Login
Overview
Comment:commit of re-hacked run code. completely torn to shreds and rewritten
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | reorg-runs-code
Files: files | file ages | folders
SHA1: 3aeabde95dcc1fde02d12b9b09f33e1bd0c0e0f9
User & Date: matt on 2011-11-20 22:36:08
Other Links: branch diff | manifest | tags
Context
2011-11-20
22:39
Fixed compilation check-in: ddc42ef201 user: matt tags: reorg-runs-code
22:36
commit of re-hacked run code. completely torn to shreds and rewritten check-in: 3aeabde95d user: matt tags: reorg-runs-code
2011-11-19
16:49
Updated diagrams check-in: 78b5afb1e6 user: matt tags: reorg-runs-code
Changes

Modified configf.scm from [ef264b880e] to [e31d2a9565].

74
75
76
77
78
79
80

81
82
83
84
85
86
87
88
89
90










91
92





93
94
95
96
97
98
99
74
75
76
77
78
79
80
81










82
83
84
85
86
87
88
89
90
91
92

93
94
95
96
97
98
99
100
101
102
103
104







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

-
+
+
+
+
+







	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res allow-system environ-patt: environ-patt)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (if allow-system
						  (let ((alist (hash-table-ref/default res curr-section-name '()))
							(val-proc (lambda ()
							(val   (let* ((cmdres  (cmd-run->list cmd))
								      (status  (cadr cmdres))
								      (res     (car  cmdres)))
								 (if (not (eq? status 0))
								     (begin
								       (debug:print 0 "ERROR: problem with " inl ", return code " status)
								       (exit 1)))
								 (if (null? res)
								     ""
								     (string-intersperse res " ")))))
								    (let* ((cmdres  (cmd-run->list cmd))
									   (status  (cadr cmdres))
									   (res     (car  cmdres)))
								      (if (not (eq? status 0))
									  (begin
									    (debug:print 0 "ERROR: problem with " inl ", return code " status)
									    (exit 1)))
								      (if (null? res)
									  ""
									  (string-intersperse res " "))))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist key val))
								     (config:assoc-safe-add alist
											    key 
											    (if (eq? allow-system 'return-procs)
												val
												(val))))
						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
						     (envar   (and environ-patt (string-match (regexp environ-patt) curr-section-name)))
						     (realval (if envar
								 (config:eval-string-in-environment val)
								 val)))

Modified db.scm from [65214cf6f3] to [c39ab57eb7].

111
112
113
114
115
116
117

118
119
120
121
122
123
124
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125







+







                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',
                                     jobgroup    TEXT DEFAULT 'default',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
205
206
207
208
209
210
211



212
213
214
215
216
217
218
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222







+
+
+







       (db:set-var db "MEGATEST_VERSION" 1.27)
       (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
       (patch-db))
      ((< mver 1.29)
       (db:set-var db "MEGATEST_VERSION" 1.29)
       (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
      ((< mver 1.36)
       (db:set-var db "MEGATEST_VERSION" 1.36)
       (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
      ((< mver megatest-version)
       (db:set-var db "MEGATEST_VERSION" megatest-version))))))

;;======================================================================
;; meta get and set vars
;;======================================================================

414
415
416
417
418
419
420













421
422
423
424
425
426
427
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







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







  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';")
    res))

(define (db:get-count-tests-running-in-jobgroup db jobgroup)
  (if (not jobgroup)
      0 ;; 
      (let ((res 0))
	(sqlite3:for-each-row
	 (lambda (count)
	   (set! res count))
	 db
	 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART'
             AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?;"
	 jobgroup)
	res)))

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining db run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
692
693
694
695
696
697
698




























699
700
701
702
703
704
705
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







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







		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (begin
					(set! ever-seen #t)
					(if (not (and (equal? (db:test-get-state test) "COMPLETED")
						      (member (db:test-get-status test) '("PASS" "WARN" "CHECK"))))
					    (set! result (cons waitontest-name result))))))
				tests)
		      (if (not ever-seen)(set! result (cons waitontest-name result)))))
		  waiton)
	(delete-duplicates result))))

;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
(define (db:get-prereqs-not-met db run-id waiton ref-item-path)
  (if (null? waiton)
      '()
      (let* ((unmet-pre-reqs '())
	     (tests           (db-get-tests-for-run db run-id #f #f '() '()))
	     (result         '()))
	(for-each (lambda (waitontest-name)
		    (let ((ever-seen #f))
		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (let* ((state         (db:test-get-state test))
					     (status        (db:test-get-status test))
					     (item-path     (db:test-get-item-path test))
					     (is-completed  (equal? state "COMPLETED"))
					     (is-ok         (member status '("PASS" "WARN" "CHECK" "WAIVED")))
					     (same-itempath (equal? ref-item-path item-path)))
					(set! ever-seen #t)
					(if (or (
					    (set! result (cons waitontest-name result))))))
				tests)
		      (if (not ever-seen)(set! result (cons waitontest-name result)))))
		  waiton)
	(delete-duplicates result))))

;;======================================================================
;; Extract ods file from the db

Modified megatest-version.scm from [c9e5e7d31e] to [27dcca5421].

1
2
3
4
5
6

7
1
2
3
4
5

6
7





-
+

;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.34)
(define megatest-version 1.36)

Modified runs.scm from [253a55cec5] to [9e5179a7af].

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







-
-
-
+
+
+
+
+
+
+



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








(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

(define (runs:can-run-more-tests db)
  (let ((num-running (db:get-count-tests-running db))
	(max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
(define (runs:can-run-more-tests db test-record)
  (let* ((tconfig                 (tests:testqueue-get-testconfig test-record))
	 (jobgroup                (config-lookup tconfig "requirements" "jobgroup"))
	 (num-running             (db:get-count-tests-running db))
	 (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup))
	 (max-concurrent-jobs     (config-lookup *configdat* "setup"     "max_concurrent_jobs"))
	 (job-group-limit         (config-lookup *configdat* "jobgroups" jobgroup)))
    (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
    (if (not (eq? 0 *globalexitstatus*))
	#f
	(let ((can-not-run-more (cond
	(if (or (not max-concurrent-jobs)
		(and max-concurrent-jobs
		     (string->number max-concurrent-jobs)
		     (not (>= num-running (string->number max-concurrent-jobs)))))
				 ;; if max-concurrent-jobs is set and the number running is greater 
				 ;; than it than cannot run more jobs
				 ((and max-concurrent-jobs
				       (string->number max-concurrent-jobs)
				       (>= num-running (string->number max-concurrent-jobs)))
	    #t
	    (begin 
	      (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running 
			   ", max_concurrent_jobs: " max-concurrent-jobs)
	      #f)))))

				  (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running 
					       ", max_concurrent_jobs: " max-concurrent-jobs)
				  #t)
				 ;; if job-group-limit is set and number of jobs in the group is greater
				 ;; than the limit then cannot run more jobs of this kind
				 ((and job-group-limit
				       (>= num-running-in-jobgroup job-group-limit))
				  (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup 
					       " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record))
				  #t)
				 (else #f))))
	  (not can-not-run-more)))))

;;======================================================================
;; New methodology. These routines will replace the above in time. For
;; now the code is duplicated. This stuff is initially used in the monitor
;; based code.
;;======================================================================

153
154
155
156
157
158
159

160

161
162
163
164
165
166
167
165
166
167
168
169
170
171
172

173
174
175
176
177
178
179
180







+
-
+







;; 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 item-patts user flags)
  (let* ((keys        (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)))
	 (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))
	 ;; (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

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


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

310
311
312
313
314




315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

336
337
338
339
340

341
342
343
344
345
346
347
348
349
350
351

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370












371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
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
417
418
419
420
421
422
423
424
425
426
427
428























































429
430
431
432
433
434
435
436
437
207
208
209
210
211
212
213


214
215
216


217
218
219

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





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
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325

326
327
328
329
330
331
332
333

334




335
336

337
338

339








340


























341
342
343





344





345
346
347
348





















349





350











351



















352
353
354
355
356
357
358
359
360
361
362
363


























































364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
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
417
418


419
420
421
422
423
424
425







-
-



-
-
+
+

-
+
+















+
+

+


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

-
+






+
-
+
-
-
-
-
+
+
-


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







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

    (set! *passnum* (+ *passnum* 1))

    ;; now add non-directly referenced dependencies (i.e. waiton)
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))
	  (let* ((config  (test:get-testconfig hed #f))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	  (let* ((config  (test:get-testconfig hed 'return-procs))
		 (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
					  (if w w "")))))
					  (if w w ""))))
		 (items   (items:get-items-from-config config)))
	    (if (not (hash-table-ref/default test-records hed #f))
		(hash-table-set! test-records hed (vector hed config waitons (config-lookup "requirements" "priority") #f)))
	    (for-each 
	     (lambda (waiton)
	       (if (and waiton (not (member waiton test-names)))
		   (begin
		     (set! required-tests (cons waiton required-tests))
		     (set! test-names (append test-names (list waiton))))))
	     waitons)
	    (let ((remtests (delete-duplicates (append waitons tal))))
	      (if (not (null? remtests))
		  (loop (car remtests)(cdr remtests)))))))

    (if (not (null? required-tests))
	(debug:print 1 "INFO: Adding " required-tests " to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (runs:run-tests-queue test-records)))

(define (runs:run-tests-queue  test-records keyvallist)
    ;; At this point the list of parent tests is expanded 
    ;; NB// Should expand items here and then insert into the run queue.
    (let ((sorted-testnames (tests:sort-by-priority-and-waiton test-records)))
    (let loop ((numtimes 0))
      (let loop (; (numtimes 0) ;; shouldn't need this
      (for-each 
       (lambda (test-record)
	 ;; need to inspect the items field tests:testqueue-get-items
		 (hed         (car sorted-test-names))
		 (tal         (cdr sorted-test-names)))
	(let* ((test-record (hash-table-ref test-records hed))
	       (tconfig     (tests:testqueue-get-testconfig test-record))
	       (waitons     (tests:testqueue-get-waitons    test-record))
	       (priority    (tests:testqueue-get-priority   test-record))
	       (itemdat     (tests:testqueue-get-itemdat    test-record))
	 ;;
	 ;;  if #f then no items for this test, check prereqs and launch
	 ;; 
	 ;;  else if list, then have items
	 ;;
	       (items       (tests:testqueue-get-items      test-record))
	       (item-path   (item-list->path itemdat)))
	  (cond
	   ((not items) ;; when false the test is ok to be handed off to launch
	    (let ((have-resources  (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
		  (prereqs-not-met (db:get-prereqs-not-met db run-id waiton item-path)))
	      (if (and have-resources
		       (null? prereqs-not-met))
		  ;; no loop - drop though and use the loop at the bottom 
		  (run:test db run-id runname keyvallst test-record flags)
		  ;; else the run is stuck, temporarily or permanently
		  (let ((newtal (append tal (list hed))))
		    ;; couldn't run, take a breather
		    (thread-sleep! 1)
		    (loop (car tal)(cdr tal))))))
	   
	   ;; case where an items came in as a list been processed
	   ((and (list? items)     ;; thus we know our items are already calculated
		 (not   itemdat)) ;; and not yet expanded into the list of things to be done
	    (if (>= *verbosity* 1)(pp items))
	    ;; (if (>= *verbosity* 5)
	 ;; if proc then eval it.
	 ;;
	 (let ((items (items:get-items-from-config tconfig)))
	 (if (runs:can-run-more-tests db test-record) ;; now needs to look at the test group
	     (run:test db run-id runname test-name keyvallst item-patts flags)
	     ))
       (tests:sort-by-priority-and-waiton test-records))
      ;; (run-waiting-tests db)
      (if keepgoing
	  (let ((estrem (db:estimated-tests-remaining db run-id)))
	    (if (and (> estrem 0)
		     (eq? *globalexitstatus* 0))
		(begin
		  (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
		  (thread-sleep! 3)
		  (run-waiting-tests db)
		  (loop (+ numtimes 1)))))))))
	    ;;     (begin
	    ;;       (print "items: ")     (pp (item-assoc->item-list items))
	    ;;       (print "itemstable: ")(pp (item-table->item-list itemstable))))
	    (for-each
	     (lambda (my-itemdat)
	       (let* ((new-test-record (vector-copy! test-record (make-tests:testqueue)))
		      (my-item-path (item-list->path my-itemdat))
		      (item-matches (if item-patts       ;; here we are filtering for matches with -itempatt
					(let ((res #f))	 ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
					  (for-each 
					   (lambda (patt)
					     (if (string-search (glob->regexp
								 (string-translate patt "%" "*"))
								item-path)
						 (set! res #t)))
					   (string-split item-patts ","))
					  res)
					#t)))
		 (if item-matches ;; yes, we want to process this item
		     (begin
		       (tests:testqueue-set-items!   new-test-record #f)
		       (tests:testqueue-set-itemdat! new-test-record my-itemdat)
		       (set! tal (cons (conc hed "/" my-item-path) tal)))))) ;; since these are itemized create new test names testname/itempath
	     items)
	    (loop (car tal)(cdr tal)))

	   ;; if items is a proc then need to evaluate, get the list and loop - but only do that if 
	   ;; resources exist to kick off the job
	   ((procedure? items)
	    (if (runs:can-run-more-tests db test-record)
		(let ((items-list (items)))
		  (if (list? items-list)
		      (begin
			(tests:testqueue-set-items test-record items-list)
			(loop hed tal))
		      (begin
			(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
			(exit 1))))
		(let ((newtal (append tal (list hed))))
		  ;; if can't run more tests, lets take a breather
		  (thread-sleep! 1)
		  (loop (car newtal)(cdr newtal)))))

	   ;; this case should not happen, added to help catch any bugs
	   ((and (list? items) itemdat)
	    (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
	    (exit 1)))
	  
	  ;; we get here on "drop through" - loop for next test in queue
	  (if (null? tal)
	      (debug:print 1 "INFO: All tests launched")
	      (loop (car tal)(cdr tal)))))))

(define (run:test db run-id runname test-name keyvallst item-patts flags)
(define (run:test db run-id runname keyvallst test-record flags)
  (debug:print 1 "Launching test " test-name)
  ;; All these vars might be referenced by the testconfig file reader
  (setenv "MT_TEST_NAME" test-name) ;; 
  (setenv "MT_RUNNAME"   runname)
  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
  (change-directory *toppath*)
  (let* ((test-name    (tests:testqueue-get-testname test-record))
  (let* ((test-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
	 (test-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (test-conf    (if testexists (read-config test-configf #f #t) (make-hash-table)))
	 (waiton       (let ((w (config-lookup test-conf "requirements" "waiton")))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
			 (if (string? w)(string-split w)'())))
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f)))
	 ;; Are these tags still used? I don't think so...
	 ;;(tags         (let ((t (config-lookup test-conf "setup" "tags")))
	 ;;       	 ;; we want our tags to be separated by commas and fully delimited by commas
	 ;;       	 ;; so that queries with "like" can tie to the commas at either end of each tag
	 ;;       	 ;; while also allowing the end user to freely use spaces and commas to separate tags
	 ;;       	 (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t)
	 ;;       	     '()))))
	 )

    (if (not testexists)
	;; if the test is ill defined spit out an error but keep going (different from how done previously
	(debug:print 0 "ERROR: Can't find config file " test-configf)
	;; put top vars into convenient variables and open the db
	(let* (;; db is always at *toppath*/db/megatest.db
	       (items       (hash-table-ref/default test-conf "items" '()))
	       (itemstable  (hash-table-ref/default test-conf "itemstable" '()))
	       (allitems    (if (or (not (null? items))(not (null? itemstable)))
				(append (item-assoc->item-list items)
					(item-table->item-list itemstable))
				'(())))) ;; a list with one null list is a test with no items
	  ;; (runconfigf  (conc  *toppath* "/runconfigs.config")))
	  (debug:print 1 "items: ")
	  (if (>= *verbosity* 1)(pp allitems))
	  (if (>= *verbosity* 5)
	      (begin
		(print "items: ")(pp (item-assoc->item-list items))
		(print "itemstable: ")(pp (item-table->item-list itemstable))))

	  ;; Comments are loaded by the test run, not at launch time (in general)
	  ;;(if (args:get-arg "-m")
	  ;;    (db:set-comment-for-run db run-id (args:get-arg "-m")))

	  ;; Here is where the test_meta table is best updated
	  (runs:update-test_meta db test-name test-conf)

    ;; Here is where the test_meta table is best updated
    (runs:update-test_meta db test-name test-conf)
    
	  ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
	  (if (null? allitems)(set! allitems '(())))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    ;; Handle lists of items
	    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
		   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
		   (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
		   (testdat   #f)
    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
	   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	   (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
	   (testdat       #f)
		   (num-running (db:get-count-tests-running db))
		   (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
		   (parent-test (and (not (null? items))(equal? item-path "")))
		   (single-test (and (null? items) (equal? item-path "")))
		   (item-test   (not (equal? item-path "")))
		   ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
		   (item-matches (if item-patts
				     (let ((res #f))
				       (for-each 
					(lambda (patt)
					  (if (string-search (glob->regexp
							      (string-translate patt "%" "*"))
							     item-path)
					      (set! res #t)))
					(string-split item-patts ","))
				       res)
				     #t)))
	      (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	      (if (and item-matches (runs:can-run-more-tests db))
		  (begin
		    (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
	   (test-info (db:get-test-info db run-id test-name item-path)))
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)
      (if (not test-info)(register-test db run-id test-name item-path))
			    ;; Why did I set the comment here?!? POSSIBLE BUG BUT I'M REMOVING IT FOR NOW 10/23/2011
			    ;; (db:test-set-comment db run-id test-name item-path "")
			    (loop2 (db:get-test-info db run-id test-name item-path)
				   (+ ct 1)))
			  (if ts
			      (set! testdat ts)
			      (begin
				(debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
				(if (not (null? tal))
				    (loop (car tal)(cdr tal)))))))
		    (change-directory test-path)
      (change-directory test-path)
		    ;; this block is here only to inform the user early on
		    
		    ;; Moving this to the run calling block

		    ;; (if (file-exists? runconfigf)
		    ;;     (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
		    ;;     (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
		    (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
		    (case (if force ;; (args:get-arg "-force")
			      'NOT_STARTED
			      (if testdat
				  (string->symbol (test:get-state testdat))
				  'failed-to-insert))
		      ((failed-to-insert)
		       (debug:print 0 "ERROR: Failed to insert the record into the db"))
		      ((NOT_STARTED COMPLETED)
		       (debug:print 6 "Got here, " (test:get-state testdat))
		       (let ((runflag #f))
			 (cond
      (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
      (case (if force ;; (args:get-arg "-force")
		'NOT_STARTED
		(if testdat
		    (string->symbol (test:get-state testdat))
		    'failed-to-insert))
	((failed-to-insert)
	 (debug:print 0 "ERROR: Failed to insert the record into the db"))
	((NOT_STARTED COMPLETED)
	 (debug:print 6 "Got here, " (test:get-state testdat))
	 (let ((runflag #f))
	   (cond
			  ;; i.e. this is the parent test to a suite of items, never "run" it
			  (parent-test
			   (set! runflag #f))
			  ;; -force, run no matter what
			  (force (set! runflag #t))
			  ;; NOT_STARTED, run no matter what
			  ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
			  ;; not -rerun and PASS, WARN or CHECK, do no run
			  ((and (or (not rerun)
				    keepgoing)
				(member (test:get-status testdat) '("PASS" "WARN" "CHECK")))
			   (set! runflag #f))
			  ;; -rerun and status is one of the specifed, run it
			  ((and rerun
				(let ((rerunlst (string-split rerun ","))) ;; FAIL,
				  (member (test:get-status testdat) rerunlst)))
			   (set! runflag #t))
			  ;; -keepgoing, do not rerun FAIL
			  ((and keepgoing
				(member (test:get-status testdat) '("FAIL")))
			   (set! runflag #f))
			  ((and (not rerun)
				(member (test:get-status testdat) '("FAIL" "n/a")))
			   (set! runflag #t))
			  (else (set! runflag #f)))
			 (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
					 (print "ERROR: Failed to launch the test. Exiting as soon as possible")
					 (set! *globalexitstatus* 1) ;; 
					 (process-signal (current-process-id) signal/kill)
					 ;(exit 1)
					 ))
				   (if (not keepgoing)
				       (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
		      ((KILLED) 
		       (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)))
			      100) ;; i.e. no update for more than 100 seconds
			   (begin
			     (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
			     (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "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))))))
	    ;; -force, run no matter what
	    (force (set! runflag #t))
	    ;; NOT_STARTED, run no matter what
	    ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
	    ;; not -rerun and PASS, WARN or CHECK, do no run
	    ((and (or (not rerun)
		      keepgoing)
		  (member (test:get-status testdat) '("PASS" "WARN" "CHECK")))
	     (set! runflag #f))
	    ;; -rerun and status is one of the specifed, run it
	    ((and rerun
		  (let ((rerunlst (string-split rerun ","))) ;; FAIL,
		    (member (test:get-status testdat) rerunlst)))
	     (set! runflag #t))
	    ;; -keepgoing, do not rerun FAIL
	    ((and keepgoing
		  (member (test:get-status testdat) '("FAIL")))
	     (set! runflag #f))
	    ((and (not rerun)
		  (member (test:get-status testdat) '("FAIL" "n/a")))
	     (set! runflag #t))
	    (else (set! runflag #f)))
	   (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
			   (print "ERROR: Failed to launch the test. Exiting as soon as possible")
			   (set! *globalexitstatus* 1) ;; 
			   (process-signal (current-process-id) signal/kill)
					;(exit 1)
			   ))
		     (if (not keepgoing)
			 (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
	((KILLED) 
	 (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")
	       (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "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)))))))
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal)))))))))

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

(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))
604
605
606
607
608
609
610
611

612
613
614
615
616
617
618
592
593
594
595
596
597
598

599
600
601
602
603
604
605
606







-
+







  (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 "%" "%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (db:update-run-event_time db new-run-id)
    ;; index the already saved tests by testname and itempath in curr-tests-hash
    ;; 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)

Modified test_records.scm from [1c9875ade7] to [7236ce2839].

1
2

3
4
5
6

7

8
9
10
11
12
13

1

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

-
+




+

+






+
;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 5))
(define (make-tests:testqueue)(make-vector 6 #f))
(define-inline (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define-inline (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define-inline (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define-inline (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define-inline (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define-inline (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))

(define-inline (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define-inline (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define-inline (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define-inline (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define-inline (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define-inline (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))