@@ -21,28 +21,28 @@ (state (get-with-default ":state" "no")) (status (get-with-default ":status" "n/a")) (allvals (append (list runname state status user) keyvallst)) (qryvals (append (list runname) keyvallst)) (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - ;; (print "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) - (print "NOTE: using key " (string-intersperse keyvallst "/") " for this run") + (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) + (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;; (print "qry: " qry) + ;(debug:print 4 "qry: " qry) qry) qryvals) (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) res) (begin - (print "ERROR: Called without all necessary keys") + (debug:print 0 "ERROR: Called without all necessary keys") #f)))) ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db @@ -62,11 +62,11 @@ (fulkey (conc ":" key)) (patt (args:get-arg fulkey))) (if patt (set! key-patt (conc key-patt " AND " key " like '" patt "'")) (begin - (print "ERROR: searching for runs with no pattern set for " fulkey) + (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keys) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) @@ -159,26 +159,26 @@ (if (member item valid-values) item #f) item))) (define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment) - ;; (print "run-id: " run-id " test-name: " test-name) + (debug:print 4 "run-id: " run-id " test-name: " test-name) (let* ((state (check-valid-items "state" state-in)) (status (check-valid-items "status" status-in)) (item-path (item-list->path itemdat)) (testdat (db:get-test-info db run-id test-name item-path))) - ;; (print "testdat: " testdat) + (debug:print 5 "testdat: " testdat) (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. (or (not state)(not status))) - (print "WARNING: Invalid " (if status "status" "state") + (debug:print 0 "WARNING: Invalid " (if status "status" "state") " value \"" (if status status-in state-in) "\", update your validstates section in megatest.config")) (if testdat (let ((test-id (test:get-id testdat))) (sqlite3:execute db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment) VALUES(?,?,?,?,strftime('%s','now'),?);" test-id teststep-name state status (if comment comment ""))) - (print "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) + (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) (define (test-get-kill-request db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) (testdat (db:get-test-info db run-id test-name item-path))) (equal? (test:get-state testdat) "KILLREQ"))) @@ -202,13 +202,13 @@ (define (test-update-meta-info db run-id testname itemdat minutes) (let ((item-path (item-list->path itemdat)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) - (if (not cpuload) (begin (print "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) - (if (not diskfree) (begin (print "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) - (if (not item-path)(begin (print "WARNING: ITEMPATH not set.") (set! item-path ""))) + (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) + (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) + (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) (sqlite3:execute db @@ -223,44 +223,44 @@ (define (set-megatest-env-vars db run-id) (let ((keys (db-get-keys db))) (for-each (lambda (key) (sqlite3:for-each-row (lambda (val) - (print "setenv " (key:get-fieldname key) " " val) + (debug:print 2 "setenv " (key:get-fieldname key) " " val) (setenv (key:get-fieldname key) val)) db (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") run-id)) keys))) (define (set-item-env-vars itemdat) (for-each (lambda (item) - (print "setenv " (car item) " " (cadr item)) + (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) (define (get-all-legal-tests) (let* ((tests (glob (conc *toppath* "/tests/*"))) (res '())) - ;; (print "INFO: Looking at tests " (string-intersperse tests ",")) + (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ",")) (for-each (lambda (testpath) (if (file-exists? (conc testpath "/testconfig")) (set! res (cons (last (string-split testpath "/")) res)))) tests) res)) (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"))) - ;; (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (if (or (not max-concurrent-jobs) (and max-concurrent-jobs (string->number max-concurrent-jobs) (not (>= num-running (string->number max-concurrent-jobs))))) #t (begin - (print "WARNING: Max running jobs exceeded, current number running: " num-running + (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running ", max_concurrent_jobs: " max-concurrent-jobs) #f)))) (define (run-tests db test-names) (let* ((keys (db-get-keys db)) @@ -268,11 +268,17 @@ (run-id (register-run db keys))) ;; test-name))) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (and (eq? *passnum* 0) (args:get-arg "-keepgoing")) - (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")) + (begin + ;; 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)) (let loop ((numtimes 0)) (for-each (lambda (test-name) (if (runs:can-run-more-tests db) @@ -283,18 +289,18 @@ ;; (run-waiting-tests db) (if (args:get-arg "-keepgoing") (let ((estrem (db:estimated-tests-remaining db run-id))) (if (> estrem 0) (begin - (print "Keep going, estimated " estrem " tests remaining to run, will continue in 10 seconds ...") - (sleep 10) + (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") + (sleep 3) (run-waiting-tests db) (loop (+ numtimes 1))))))))) ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc (define (run-one-test db run-id test-name keyvallst) - (print "Launching test " test-name) + (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" (args:get-arg ":runname")) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) @@ -304,11 +310,11 @@ (test-conf (if testexists (read-config test-configf) (make-hash-table))) (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) (if (string? w)(string-split w)'())))) (if (not testexists) (begin - (print "ERROR: Can't find config file " test-configf) + (debug:print 0 "ERROR: Can't find config file " test-configf) (exit 2)) ;; 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" '())) @@ -315,13 +321,20 @@ (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"))) - (print "items: ")(pp allitems) + (debug:print 1 "items: ") + (if (>= *verbosity* 1)(pp allitems)) + (if (>= *verbosity* 5) + (begin + (print "items: ")(pp (item-assoc->item-list items)) + (print "itestable: ")(pp (item-table->item-list itemstable)))) (if (args:get-arg "-m") (db:set-comment-for-run db run-id (args:get-arg "-m"))) + ;; 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")) ;; Handle lists of items (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) @@ -331,11 +344,11 @@ (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 "")))) - ;; (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (if (runs:can-run-more-tests db) (begin (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f) (ct 0)) (if (and (not ts) @@ -346,28 +359,28 @@ (loop2 (db:get-test-info db run-id test-name item-path) (+ ct 1))) (if ts (set! testdat ts) (begin - (print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") + (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) ;; this block is here only to inform the user early on (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) - (print "WARNING: You do not have a run config file: " runconfigf)) - ;; (print "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) + (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 (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) ((failed-to-insert) - (print "ERROR: Failed to insert the record into the db")) + (debug:print 0 "ERROR: Failed to insert the record into the db")) ((NOT_STARTED COMPLETED) - ;; (print "Got here, " (test:get-state testdat)) + (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)) @@ -391,14 +404,14 @@ (set! runflag #f)) ((and (not (args:get-arg "-rerun")) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - ;; (print "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) - (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) + (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 test-conf keyvallst test-name test-path itemdat))) (testrundat (list get-prereqs-cmd launch-cmd))) @@ -406,20 +419,20 @@ (null? ((car testrundat)))) ;; are there any tests that must be run before this one... ((cadr testrundat)) ;; this is the line that launches the test to the remote host (if (not (args:get-arg "-keepgoing")) (hash-table-set! *waiting-queue* new-test-name testrundat))))))) ((KILLED) - (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + (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 - (print "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + (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")) - (print "NOTE: " test-name " is already running"))) - (else (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))) + (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))))))))) (define (run-waiting-tests db) (let ((numtries 0) @@ -432,79 +445,88 @@ (cond ((not (runs:can-run-more-tests db)) (sleep 2) (loop waiting-test-names)) ((null? waiting-test-names) - (print "All tests launched")) + (debug:print 1 "All tests launched")) (else (set! numtries (+ numtries 1)) (for-each (lambda (testname) (if (runs:can-run-more-tests db) (let* ((testdat (hash-table-ref *waiting-queue* testname)) (prereqs ((car testdat))) (ldb (if db db (open-db)))) - ;; (print "prereqs remaining: " prereqs) + (debug:print 2 "prereqs remaining: " prereqs) (if (null? prereqs) (begin - (print "Prerequisites met, launching " testname) + (debug:print 2 "Prerequisites met, launching " testname) ((cadr testdat)) (hash-table-delete! *waiting-queue* testname))) (if (not db) (sqlite3:finalize! ldb))))) waiting-test-names) ;; (sleep 10) ;; no point in rushing things at this stage? (loop (hash-table-keys *waiting-queue*))))))) -(define (get-dir-up-one dir) - (let ((dparts (string-split dir "/"))) +(define (get-dir-up-n dir . params) + (let ((dparts (string-split dir "/")) + (count (if (null? params) 1 (car params)))) (conc "/" (string-intersperse - (take dparts (- (length dparts) 1)) + (take dparts (- (length dparts) count)) "/")))) ;; Remove runs ;; fields are passing in through (define (runs:remove-runs db runnamepatt testpatt itempatt) (let* ((keys (db-get-keys db)) (rundat (runs:get-runs-by-patt db keys runnamepatt)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) - (print "Header: " header) + (debug:print 1 "Header: " header) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) (db:get-value-by-header run header (vector-ref k 0))) keys) "/"))) (let* ((run-id (db:get-value-by-header run header "id") ) (tests (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt)) (lasttpath "/does/not/exist/I/hope")) (if (not (null? tests)) (begin - (print "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")) + (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")) (for-each (lambda (test) - (print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test)) - (db:delete-test-records db (db:test-get-id test)) - (if (> (string-length (db:test-get-rundir test)) 5) ;; bad heuristic but should prevent /tmp /home etc. - (let ((fullpath (db:test-get-rundir test))) ;; "/" (db:test-get-item-path test)))) - (set! lasttpath fullpath) - (print "rm -rf " fullpath) - (system (conc "rm -rf " fullpath)) - (let ((cmd (conc "rmdir -p " (get-dir-up-one fullpath)))) - (print cmd) - (system cmd)) - ))) - tests))) + (let* ((item-path (db:test-get-item-path test)) + (test-name (db:test-get-testname test)) + (run-dir (db:test-get-rundir test))) + (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path) + (db:delete-test-records db (db:test-get-id test)) + (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc. + (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test)))) + (set! lasttpath fullpath) + (debug:print 1 "rm -rf " fullpath) + (system (conc "rm -rf " fullpath)) + (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/")))) + (dir-to-rem (get-dir-up-n fullpath dirs-count)) + (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath)) + (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd ))) + (if (file-exists? fullpath) + (begin + (debug:print 1 cmd) + (system cmd))) + )) + ))) + tests))) (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id")))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) - (print "Removing run: " runkey " " (db:get-value-by-header run header "runname")) + (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname")) (db:delete-run db run-id) ;; need to figure out the path to the run dir and remove it if empty - ;; (if (null? (glob (conc runpath "/*"))) - ;; (begin - ;; (print "Removing run dir " runpath) - ;; (system (conc "rmdir -p " runpath)))) - ))) - ))) + ;; (if (null? (glob (conc runpath "/*"))) + ;; (begin + ;; (debug:print 1 "Removing run dir " runpath) + ;; (system (conc "rmdir -p " runpath)))) + )))) + )) runs))) -