@@ -29,12 +29,12 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (define (runs:test-get-full-path test) - (let* ((testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test))) + (let* ((testname (db:test-testname test)) + (itempath (db:test-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) ;; This is the *new* methodology. One record to inform them and in the chaos, organise them. ;; ;; NOT YET UTILIZED @@ -611,14 +611,14 @@ (exit 1)))))) ((and (null? fails) (null? prereq-fails) (not (null? non-completed))) - (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-testname x))) (append newtal reruns))) ;; prereqstrs is a list of test names as strings that are prereqs for hed - (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-testname x))) prereqs-not-met))) ;; a prereq that is not found in allinqueue will be put in the notinqueue list ;; ;; (notinqueue (filter (lambda (x) ;; (not (member x allinqueue))) @@ -676,11 +676,11 @@ ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") + (string-intersperse (map (lambda (t)(conc (db:test-testname t) ":" (db:test-state t)"/"(db:test-status t))) fails) ", ") ", removing it from to-do list") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (if (not (null? prereq-fails)) (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") @@ -711,14 +711,14 @@ (if (null? inlst) '() (map (lambda (t) (cond ((vector? t) - (let ((test-name (db:test-get-testname t)) - (item-path (db:test-get-item-path t)) - (test-state (db:test-get-state t)) - (test-status (db:test-get-status t))) + (let ((test-name (db:test-testname t)) + (item-path (db:test-item-path t)) + (test-state (db:test-state t)) + (test-status (db:test-status t))) (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status))) ((string? t) t) (else (conc t)))) @@ -744,11 +744,11 @@ (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse (map (lambda (t) (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc (db:test-state t) "/" (db:test-status t)) (conc " WARNING: t is not a vector=" t ))) prereqs-not-met) ", ") ") fails: " fails "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) @@ -895,11 +895,11 @@ (runs:queue-next-reg tal reg reglen regfull) reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? )) (let ((nth-try (hash-table-ref/default test-registry hed 0))) (cond - ((member "RUNNING" (map db:test-get-state prereqs-not-met)) + ((member "RUNNING" (map db:test-state prereqs-not-met)) (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) (debug:print 0 "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) (thread-sleep! 4) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) @@ -960,12 +960,12 @@ ;; scan a list of tests looking to see if any are potentially runnable (define (runs:runable-tests tests) (filter (lambda (t) (if (not (vector? t)) t - (let ((state (db:test-get-state t)) - (status (db:test-get-status t))) + (let ((state (db:test-state t)) + (status (db:test-status t))) (case (string->symbol state) ((COMPLETED INCOMPLETE) #f) ((NOT_STARTED) (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" )) #f @@ -1006,14 +1006,14 @@ (tdbdat (tasks:open-db))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) - (let ((id (db:test-get-id trec)) - (tn (db:test-get-testname trec)) - (ip (db:test-get-item-path trec)) - (st (db:test-get-state trec))) + (let ((id (db:test-id trec)) + (tn (db:test-testname trec)) + (ip (db:test-item-path trec)) + (st (db:test-state trec))) (if (not (equal? st "DELETED")) (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st))))) tests-info) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) @@ -1243,51 +1243,51 @@ (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) - (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) - (not (member (db:test-get-status test) + (member (db:test-state test) '("INCOMPLETE" "COMPLETED")) + (not (member (db:test-status test) '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))))) prereqs-not-met)) (define (runs:calc-prereq-fail prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) - (equal? (db:test-get-state test) "NOT_STARTED") - (not (member (db:test-get-status test) + (equal? (db:test-state test) "NOT_STARTED") + (not (member (db:test-status test) '("n/a" "KEEP_TRYING"))))) prereqs-not-met)) (define (runs:calc-not-completed prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) - (not (member (db:test-get-state t) '("INCOMPLETE" "COMPLETED"))))) + (not (member (db:test-state t) '("INCOMPLETE" "COMPLETED"))))) prereqs-not-met)) ;; (define (runs:calc-not-completed prereqs-not-met) ;; (filter ;; (lambda (t) ;; (or (not (vector? t)) -;; (not (equal? "COMPLETED" (db:test-get-state t))))) +;; (not (equal? "COMPLETED" (db:test-state t))))) ;; prereqs-not-met)) (define (runs:calc-runnable prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) - (and (equal? "NOT_STARTED" (db:test-get-state t)) - (member (db:test-get-status t) + (and (equal? "NOT_STARTED" (db:test-state t)) + (member (db:test-status t) '("n/a" "KEEP_TRYING"))))) prereqs-not-met)) (define (runs:pretty-string lst) (map (lambda (t) (if (not (vector? t)) (conc t) - (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) + (conc (db:test-testname t) ":" (db:test-state t) "/" (db:test-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader @@ -1359,11 +1359,11 @@ (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) - (set! test-id (db:test-get-id testdat)) + (set! test-id (db:test-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") (change-directory *toppath*))) @@ -1457,12 +1457,12 @@ ((KILLED) (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) (debug:print 2 "NOTE: " test-name " is already running")) - ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) + ;; (if (> (- (current-seconds)(+ (db:test-event_time testdat) + ;; (db:test-run_duration testdat))) ;; (or incomplete-timeout ;; 6000)) ;; i.e. no update for more than 6000 seconds ;; (begin ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) @@ -1596,37 +1596,37 @@ ;; actions that operate on one test at a time can be handled below ;; (let ((sorted-tests (filter vector? (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) + (db:test-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-rundir a))) (dirb ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) + (db:test-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f)))))) (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) - (let* ((test-id (db:test-get-id test)) + (let* ((test-id (db:test-id test)) (new-test-dat (rmt:get-test-info-by-id run-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) - (let* ((item-path (db:test-get-item-path new-test-dat)) - (test-name (db:test-get-testname new-test-dat)) + (let* ((item-path (db:test-item-path new-test-dat)) + (test-name (db:test-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* ;; (rmt:sdb-qry 'getid - (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree - (test-state (db:test-get-state new-test-dat)) - (test-fulln (db:test-get-fullname new-test-dat)) - (uname (db:test-get-uname new-test-dat)) - (toplevel-with-children (and (db:test-get-is-toplevel test) + (db:test-rundir new-test-dat)) ;; ) ;; run dir is from the link tree + (test-state (db:test-state new-test-dat)) + (test-fulln (db:test-fullname new-test-dat)) + (uname (db:test-uname new-test-dat)) + (toplevel-with-children (and (db:test-is-toplevel test) (> (rmt:test-toplevel-num-items run-id test-name) 0)))) (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children @@ -1650,14 +1650,14 @@ ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) @@ -1665,11 +1665,11 @@ (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal)))))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (mt:test-set-state-status-by-id run-id (db:test-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) @@ -1712,18 +1712,18 @@ ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) ) #t) (define (runs:remove-test-directory test mode) ;; remove-data-only) - (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree + (let* ((run-dir (db:test-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f))) (case mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) - ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "CLEANING" "LOCKED" #f)) + ((remove-all) (mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "REMOVING" "LOCKED" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) @@ -1753,13 +1753,13 @@ (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record (case mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "NOT_STARTED" "n/a" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "ARCHIVED" #f #f)) + (else (rmt:delete-test-records (db:test-run_id test) (db:test-id test)))))) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== @@ -1873,25 +1873,25 @@ (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time 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)) + (let* ((testname (db:test-testname testdat)) + (item-path (db:test-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)) + (let* ((testname (db:test-testname testdat)) + (item-path (db:test-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test (db:test-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) " @@ -1898,24 +1898,24 @@ "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc 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)) + (debug:print 4 "Copying records in test_steps from test_id=" (db:test-id testdat) " to " (db:test-id new-testdat)) (cdb:remote-run ;; to be replaced, note: this routine is not used currently (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)) + "SELECT " (db:test-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") + (db:test-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)) + (debug:print 4 "Copying records in test_data from test_id=" (db:test-id testdat) " to " (db:test-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)))) + "SELECT " (db:test-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") + (db:test-id testdat)))) )) prev-tests)))