322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
|
+
|
(readonly-mode (not (file-write-access? dbfile)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
(required-tests #f) ;; Put fully qualified test/testpath names in this list to be done
(waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test.
(task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
;; (tdbdat (tasks:open-db))
(config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(allowed-tests #f))
;; check if readonly
|
469
470
471
472
473
474
475
476
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
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
|
470
471
472
473
474
475
476
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
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
|
-
+
+
-
+
+
-
-
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
|
;;======================================================================
(if (not (null? test-names))
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
(let*-values (((waitons waitors config)
(tests:get-waitons hed all-tests-registry)))
(debug:print-info 8 *default-log-port* "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (or (member hed waitons)
(member hed waitors))
(begin
(debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
(set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
(tests:get-items config) ;; expand the [items] and or [itemstable] into explict items
#f ;; itemsdat 5
#f ;; spare - used for item-path
waitors ;;
)))
;; update waitors-upon here
(for-each
(lambda (waiton)
(let* ((waiton-record (hash-table-ref/default test-records waiton #f))
(new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) ;; BB: items expanded here
(new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) ;; BB: items expanded here - chained-waiton goes awry by now.
(debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
;; is this satisfied by merely appending "/" to the waiton name added to the list?
;;
;; This approach causes all of the items in an upstream test to be run
;; if we have this waiton already processed once we can analzye it for extending
;; tests to be run, since we can't properly process waitons unless they have been
;; initially added we add them again to be processed on second round AND add the hed
;; back in to also be processed on second round
;;
(if waiton-tconfig
(if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig.
(begin
(set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
(if waiton-itemized
(if waitors-in-testpatt
(begin
(debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
(set! required-tests (cons (conc waiton "/") required-tests))
(set! test-patts new-test-patts))
(begin
|
645
646
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
|
-
|
(define runs:nothing-left-in-queue-count 0)
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;; (let loop ((hed (car sorted-test-names))
;; (tal (cdr sorted-test-names))
;; (reg '()) ;; registered, put these at the head of tal
;; (reruns '()))
;; BB: for future reference - suspect target vars are not expanded to env vars at this point (item expansion using [items]\nwhatever [system echo $TARGETVAR] doesnt work right whereas [system echo #{targetvar}] does.. Tal and Randy have tix on this. on first pass, var not set, on second pass, ok.
|