6 ;; 6 ;; 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 9 ;; PURPOSE. 9 ;; PURPOSE. 10 10 11 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') 11 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') 12 12 13 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) | 13 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) 14 (import (prefix sqlite3 sqlite3:)) 14 (import (prefix sqlite3 sqlite3:)) 15 15 16 (declare (unit runs)) 16 (declare (unit runs)) 17 (declare (uses db)) 17 (declare (uses db)) 18 (declare (uses common)) 18 (declare (uses common)) 19 (declare (uses items)) 19 (declare (uses items)) 20 (declare (uses runconfig)) 20 (declare (uses runconfig)) ................................................................................................................................................................................ 257 (if (not (null? remtests)) 257 (if (not (null? remtests)) 258 (loop (car remtests)(cdr remtests))))))) 258 (loop (car remtests)(cdr remtests))))))) 259 259 260 (if (not (null? required-tests)) 260 (if (not (null? required-tests)) 261 (debug:print 1 "INFO: Adding " required-tests " to the run queue")) 261 (debug:print 1 "INFO: Adding " required-tests " to the run queue")) 262 ;; NOTE: these are all parent tests, items are not expanded yet. 262 ;; NOTE: these are all parent tests, items are not expanded yet. 263 (runs:run-tests-queue db run-id runname test-records keyvallst flags) 263 (runs:run-tests-queue db run-id runname test-records keyvallst flags) > 264 (if *rpc:listener* (server:keep-running db)) 264 (debug:print 4 "INFO: All done by here"))) 265 (debug:print 4 "INFO: All done by here"))) 265 266 266 (define (runs:run-tests-queue db run-id runname test-records keyvallst flags) 267 (define (runs:run-tests-queue db run-id runname test-records keyvallst flags) 267 ;; At this point the list of parent tests is expanded 268 ;; At this point the list of parent tests is expanded 268 ;; NB// Should expand items here and then insert into the run queue. 269 ;; NB// Should expand items here and then insert into the run queue. 269 (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst) 270 (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst) 270 (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) 271 (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) ................................................................................................................................................................................ 360 (debug:print 0 "ERROR: Should not have a list of items in a test and t 361 (debug:print 0 "ERROR: Should not have a list of items in a test and t 361 (exit 1)))) 362 (exit 1)))) 362 363 363 ;; we get here on "drop through" - loop for next test in queue 364 ;; we get here on "drop through" - loop for next test in queue 364 (if (null? tal) 365 (if (null? tal) 365 (begin 366 (begin 366 ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! 367 ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! 367 (debug:print 1 "INFO: All tests launched, exiting") | 368 (debug:print 1 "INFO: All tests launched") 368 (exit 0)) | 369 ;; (exit 0) > 370 ) 369 (loop (car tal)(cdr tal)))))) 371 (loop (car tal)(cdr tal)))))) 370 372 371 ;; parent-test is there as a placeholder for when parent-tests can be run as a s 373 ;; parent-test is there as a placeholder for when parent-tests can be run as a s 372 (define (run:test db run-id runname keyvallst test-record flags parent-test) 374 (define (run:test db run-id runname keyvallst test-record flags parent-test) 373 ;; All these vars might be referenced by the testconfig file reader 375 ;; All these vars might be referenced by the testconfig file reader 374 (let* ((test-name (tests:testqueue-get-testname test-record)) 376 (let* ((test-name (tests:testqueue-get-testname test-record)) 375 (test-waitons (tests:testqueue-get-waitons test-record)) 377 (test-waitons (tests:testqueue-get-waitons test-record)) ................................................................................................................................................................................ 390 (debug:print 2 "Attempting to launch test " test-name "/" item-path) 392 (debug:print 2 "Attempting to launch test " test-name "/" item-path) 391 (setenv "MT_TEST_NAME" test-name) ;; 393 (setenv "MT_TEST_NAME" test-name) ;; 392 (setenv "MT_RUNNAME" runname) 394 (setenv "MT_RUNNAME" runname) 393 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr 395 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr 394 (change-directory *toppath*) 396 (change-directory *toppath*) 395 397 396 ;; Here is where the test_meta table is best updated 398 ;; Here is where the test_meta table is best updated > 399 ;; Yes, another use of a global for caching. Need a better way? > 400 (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) > 401 (begin > 402 (hash-table-set! *test-meta-updated* test-name #t) 397 (runs:update-test_meta db test-name test-conf) | 403 (runs:update-test_meta db test-name test-conf))) 398 404 399 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 405 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 400 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 406 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 401 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 407 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 402 (testdat (db:get-test-info db run-id test-name item-path))) | 408 (testdat (db:get-test-info db run-id test-name item-path)) > 409 (test-id #f)) 403 (if (not testdat) 410 (if (not testdat) 404 (begin 411 (begin 405 ;; ensure that the path exists before registering the test 412 ;; ensure that the path exists before registering the test 406 ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 413 ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 407 ;; (system (conc "mkdir -p " new-test-path)) 414 ;; (system (conc "mkdir -p " new-test-path)) 408 (rtests:register-test db run-id test-name item-path) 415 (rtests:register-test db run-id test-name item-path) 409 (set! testdat (db:get-test-info db run-id test-name item-path)))) 416 (set! testdat (db:get-test-info db run-id test-name item-path)))) > 417 (set! test-id (db:test-get-id testdat)) 410 (change-directory test-path) 418 (change-directory test-path) 411 (case (if force ;; (args:get-arg "-force") 419 (case (if force ;; (args:get-arg "-force") 412 'NOT_STARTED 420 'NOT_STARTED 413 (if testdat 421 (if testdat 414 (string->symbol (test:get-state testdat)) 422 (string->symbol (test:get-state testdat)) 415 'failed-to-insert)) 423 'failed-to-insert)) 416 ((failed-to-insert) 424 ((failed-to-insert) ................................................................................................................................................................................ 447 (member (test:get-status testdat) '("FAIL" "n/a"))) 455 (member (test:get-status testdat) '("FAIL" "n/a"))) 448 (set! runflag #t)) 456 (set! runflag #t)) 449 (else (set! runflag #f))) 457 (else (set! runflag #f))) 450 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-st 458 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-st 451 (if (not runflag) 459 (if (not runflag) 452 (if (not parent-test) 460 (if (not parent-test) 453 (debug:print 1 "NOTE: Not starting test " new-test-name " as 461 (debug:print 1 "NOTE: Not starting test " new-test-name " as 454 "\" and status \"" (test:get-status testdat) "\" | 462 "\" and status \"" (test:get-status testdat) "\" > 463 "\" or -force to override")) 455 ;; NOTE: No longer be checking prerequisites here! Will never get 464 ;; NOTE: No longer be checking prerequisites here! Will never get 456 ;; already met. 465 ;; already met. 457 (if (not (launch-test db run-id runname test-conf keyvallst test- 466 (if (not (launch-test db run-id runname test-conf keyvallst test- 458 (begin 467 (begin 459 (print "ERROR: Failed to launch the test. Exiting as soon a 468 (print "ERROR: Failed to launch the test. Exiting as soon a 460 (set! *globalexitstatus* 1) ;; 469 (set! *globalexitstatus* 1) ;; 461 (process-signal (current-process-id) signal/kill)))))) 470 (process-signal (current-process-id) signal/kill)))))) ................................................................................................................................................................................ 463 (debug:print 1 "NOTE: " new-test-name " is already running or was expli 472 (debug:print 1 "NOTE: " new-test-name " is already running or was expli 464 ((LAUNCHED REMOTEHOSTSTART RUNNING) 473 ((LAUNCHED REMOTEHOSTSTART RUNNING) 465 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) 474 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) 466 (db:test-get-run_duration testdat))) 475 (db:test-get-run_duration testdat))) 467 600) ;; i.e. no update for more than 600 seconds 476 600) ;; i.e. no update for more than 600 seconds 468 (begin 477 (begin 469 (debug:print 0 "WARNING: Test " test-name " appears to be dead. F 478 (debug:print 0 "WARNING: Test " test-name " appears to be dead. F 470 (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" i | 479 (test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is s 471 (debug:print 2 "NOTE: " test-name " is already running"))) 480 (debug:print 2 "NOTE: " test-name " is already running"))) 472 (else (debug:print 0 "ERROR: Failed to launch test " new-test-name 481 (else (debug:print 0 "ERROR: Failed to launch test " new-test-name 473 482 474 ;;====================================================================== 483 ;;====================================================================== 475 ;; END OF NEW STUFF 484 ;; END OF NEW STUFF 476 ;;====================================================================== 485 ;;====================================================================== 477 486 ................................................................................................................................................................................ 569 578 570 ;; Since many calls to a run require pretty much the same setup 579 ;; Since many calls to a run require pretty much the same setup 571 ;; this wrapper is used to reduce the replication of code 580 ;; this wrapper is used to reduce the replication of code 572 (define (general-run-call switchname action-desc proc) 581 (define (general-run-call switchname action-desc proc) 573 (let ((runname (args:get-arg ":runname")) 582 (let ((runname (args:get-arg ":runname")) 574 (target (if (args:get-arg "-target") 583 (target (if (args:get-arg "-target") 575 (args:get-arg "-target") 584 (args:get-arg "-target") 576 (args:get-arg "-reqtarg")))) | 585 (args:get-arg "-reqtarg"))) > 586 (th1 #f)) 577 (cond 587 (cond 578 ((not target) 588 ((not target) 579 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 589 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 580 (exit 3)) 590 (exit 3)) 581 ((not runname) 591 ((not runname) 582 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 592 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 583 (exit 3)) 593 (exit 3)) ................................................................................................................................................................................ 585 (let ((db #f) 595 (let ((db #f) 586 (keys #f)) 596 (keys #f)) 587 (if (not (setup-for-run)) 597 (if (not (setup-for-run)) 588 (begin 598 (begin 589 (debug:print 0 "Failed to setup, exiting") 599 (debug:print 0 "Failed to setup, exiting") 590 (exit 1))) 600 (exit 1))) 591 (set! db (open-db)) 601 (set! db (open-db)) 592 (if (not (args:get-arg "-server")) | 602 (if (args:get-arg "-server") > 603 (server:start db (args:get-arg "-server")) > 604 (if (not (or (args:get-arg "-runall") > 605 (args:get-arg "-runtests"))) 593 (server:client-setup db)) | 606 (server:client-setup db))) 594 (set! keys (rdb:get-keys db)) 607 (set! keys (rdb:get-keys db)) 595 ;; have enough to process -target or -reqtarg here 608 ;; have enough to process -target or -reqtarg here 596 (if (args:get-arg "-reqtarg") 609 (if (args:get-arg "-reqtarg") 597 (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT 610 (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT 598 (runconfig (read-config runconfigf #f #f environ-patt: #f))) 611 (runconfig (read-config runconfigf #f #f environ-patt: #f))) 599 (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f 612 (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f 600 (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg- 613 (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg- ................................................................................................................................................................................ 609 (debug:print 0 "ERROR: Attempted to " action-desc " but run area c 622 (debug:print 0 "ERROR: Attempted to " action-desc " but run area c 610 (exit 1)) 623 (exit 1)) 611 ;; Extract out stuff needed in most or many calls 624 ;; Extract out stuff needed in most or many calls 612 ;; here then call proc 625 ;; here then call proc 613 (let* ((keynames (map key:get-fieldname keys)) 626 (let* ((keynames (map key:get-fieldname keys)) 614 (keyvallst (keys->vallist keys #t))) 627 (keyvallst (keys->vallist keys #t))) 615 (proc db target runname keys keynames keyvallst))) 628 (proc db target runname keys keynames keyvallst))) > 629 (if th1 (thread-join! th1)) 616 (sqlite3:finalize! db) 630 (sqlite3:finalize! db) 617 (set! *didsomething* #t)))))) 631 (set! *didsomething* #t)))))) 618 632 619 ;;====================================================================== 633 ;;====================================================================== 620 ;; Rollup runs 634 ;; Rollup runs 621 ;;====================================================================== 635 ;;====================================================================== 622 636