︙ | | | ︙ | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
(declare (uses tests))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; stuff to be deprecated then removed
(include "old-runs.scm")
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
|
<
<
<
<
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
(declare (uses tests))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
|
︙ | | | ︙ | |
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
(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 ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority")
#f ;; 4
#f ;; 5
#f ;; spare
)))
(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))))))
|
|
>
>
>
>
>
>
>
>
|
>
>
>
|
|
|
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
|
(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 ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
(let ((items (hash-table-ref/default config "items" #f)) ;; items 4
(itemstable (hash-table-ref/default config "itemstable" #f)))
;; if either items or items table is a proc return it so test running
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
;; otherwise return #f - this is not an iterated test
(cond
((procedure? items) items) ;; calc later
((procedure? itemstable) itemstable) ;; calc later
((or (list? items)(list? itemstable)) ;; calc now
(items:get-items-from-config config))
(else #f))) ;; not iterated
#f ;; itemsdat 5
;; #f ;; spare
)))
(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))))))
|
︙ | | | ︙ | |
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
|
;; NOTE: these are all parent tests, items are not expanded yet.
(runs:run-tests-queue db run-id runname test-records keyvallst flags)))
(define (runs:run-tests-queue db run-id runname test-records keyvallst flags)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst)
(let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)))
(let loop (; (numtimes 0) ;; shouldn't need this
(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))
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat)))
(debug:print 0 "WHERE TO DO: (items:get-items-from-config config)")
(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 waitons 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)
;; (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))))
|
|
>
>
>
>
>
|
|
>
|
>
|
>
|
|
|
|
<
|
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
|
;; NOTE: these are all parent tests, items are not expanded yet.
(runs:run-tests-queue db run-id runname test-records keyvallst flags)))
(define (runs:run-tests-queue db run-id runname test-records keyvallst flags)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst)
(let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(item-patts (hash-table-ref/default flags "-itempatt" #f)))
(let loop (; (numtimes 0) ;; shouldn't need this
(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))
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat)))
(debug:print 0 "WHERE TO DO: (items:get-items-from-config config)")
(debug:print 6
"itemdat: " itemdat
"\n items: " items
"\n item-path: " item-path)
(cond
((not items) ;; when false the test is ok to be handed off to launch (but not before)
(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 waitons 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 #f)
;; 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)
;; (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 (let ((newrec (make-tests:testqueue)))
(vector-copy! test-record newrec)
newrec))
(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
(let ((newtestname (conc hed "/" my-item-path)))
(tests:testqueue-set-items! new-test-record #f)
(tests:testqueue-set-itemdat! new-test-record my-itemdat)
(hash-table-set! test-records newtestname new-test-record)
(set! tal (cons newtestname 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 run items:get-items-from-config, 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:get-items-from-config tconfig)))
(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))))
|
︙ | | | ︙ | |
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
|
(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 keyvallst test-record flags)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f)))
(debug:print 1 "Launching test " test-name)
(debug:print 5
"test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
|
>
|
|
<
>
>
|
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
(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)))))))
;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test db run-id runname keyvallst test-record flags parent-test)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f)))
(debug:print 1 "Launching test " test-name)
(debug:print 5
"test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
|
︙ | | | ︙ | |
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
|
;; Here is where the test_meta table is best updated
(runs:update-test_meta db test-name test-conf)
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
(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)
(test-info (db:get-test-info db run-id test-name item-path)))
(if (not test-info)(register-test db run-id test-name item-path))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
|
<
|
>
>
|
>
|
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
|
;; Here is where the test_meta table is best updated
(runs:update-test_meta db test-name test-conf)
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
(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 (db:get-test-info db run-id test-name item-path)))
(if (not testdat)
(begin
(register-test db run-id test-name item-path)
(set! testdat (db:get-test-info db run-id test-name item-path))))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
|
︙ | | | ︙ | |
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
|
(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 waitons))) ;; 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
|
|
<
|
|
<
<
<
<
<
<
|
|
|
|
<
<
<
<
|
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
|
(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"))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
(if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))
((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
|
︙ | | | ︙ | |
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
|
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(if (not (args:get-arg ":runname"))
(begin
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 2))
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
|
|
>
>
>
|
>
>
>
>
|
|
>
|
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
|
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(let ((runname (args:get-arg ":runname"))
(target (if (args:get-arg "-target")
(args:get-arg "-target")
(args:get-arg "-reqtarg"))))
(cond
((not target)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
(exit 3))
((not runname)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 3))
(else
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
|
︙ | | | ︙ | |
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
|
(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 keys keynames keyvallst)))
(sqlite3:finalize! db)
(set! *didsomething* #t))))
;;======================================================================
;; Rollup runs
;;======================================================================
;; Update the test_meta table for this test
(define (runs:update-test_meta db test-name test-conf)
|
|
|
|
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
|
(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)))
(sqlite3:finalize! db)
(set! *didsomething* #t))))))
;;======================================================================
;; Rollup runs
;;======================================================================
;; Update the test_meta table for this test
(define (runs:update-test_meta db test-name test-conf)
|
︙ | | | ︙ | |