Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -51,10 +51,18 @@ ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) + +;; convert stuff to a number if possible +(define (any->number val) + (cond + ((number? val) val) + ((string? val) (string->number val)) + ((symbol? val) (any->number (symbol->string val))) + (else #f))) ;;====================================================================== ;; System stuff ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -355,37 +355,11 @@ #:size "200x150" #:alignment "ALEFT:ATOP"))) (hash-table-set! widgets "Test Steps" (lambda (testdat) (let* ((currval (iup:attribute stepsdat "TITLE")) (fmtstr "~25a~10a~10a~15a~20a") - (steps (db:get-steps-for-test db test-id)) - ;; organise the steps for better readability - (comprsteps (let ((res (make-hash-table))) - (for-each - (lambda (step) - (let ((record (hash-table-ref/default - res - (db:step-get-stepname step) - ;; stepname start end status - (vector (db:step-get-stepname step) "" "" "" "")))) - (case (string->symbol (db:step-get-state step)) - ((start)(vector-set! record 1 (db:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (db:step-get-status step)))) - ((end) (vector-set! record 2 (db:step-get-event_time step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (let ((startt (vector-ref record 1)) - (endt (vector-ref record 2))) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1")))) - (else (vector-set! record 1 (db:step-get-event_time step))) - (vector-set! record 2 (db:step-get-state step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (db:step-get-event_time step))) - (hash-table-set! res (db:step-get-stepname step) record))) - steps) - res)) + (comprsteps (db:get-steps-table db test-id)) (newval (string-intersperse (append (list (format #f fmtstr "Stepname" "Start" "End" "Status" "Time") (format #f fmtstr "========" "=====" "======" "======" "==========")) @@ -419,5 +393,6 @@ (hash-table-keys widgets)) (update-state-status-buttons testdat) ; (iup:refresh self) (if *exit-started* (set! *exit-started* 'ok)))))))) + Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -475,28 +475,57 @@ db "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) -;; ;; check that *all* the prereqs are "COMPLETED" -;; (define (db-get-prereqs-met db run-id waiton) -;; (let ((res #f) -;; (not-complete 0) -;; (tests (db-get-tests-for-run db run-id))) -;; (for-each -;; (lambda (test-name) -;; (for-each -;; (lambda (test) -;; (if (equal? (db:test-get-testname test) test-name) -;; (begin -;; (set! res #t) -;; (if (not (equal? (db:test-get-state test) "COMPLETED")) -;; (set! not-complete (+ 1 not-complete)))))) -;; tests)) -;; waiton) -;; (and (or (null? waiton) res) -;; (eq? not-complete 0)))) +;; get a pretty table to summarize steps +;; +(define (db:get-steps-table db test-id) + (let ((steps (db:get-steps-for-test db test-id))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (db:step-get-stepname step) + ;; stepname start end status + (vector (db:step-get-stepname step) "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)) + (case (string->symbol (db:step-get-state step)) + ((start)(vector-set! record 1 (db:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (db:step-get-status step)))) + ((end) + (vector-set! record 2 (any->number (db:step-get-event_time step))) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (db:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1")))) + (else (vector-set! record 1 (db:step-get-event_time step))) + (vector-set! record 2 (db:step-get-state step)) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (db:step-get-event_time step))) + (hash-table-set! res (db:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)))) + (sort steps (lambda (a b)(< (db:step-get-event_time a)(db:step-get-event_time b))))) + res))) ;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) ;; ;; Return a list of prereqs that were NOT met ;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -63,12 +63,12 @@ -keepgoing : continue running until no jobs are \"LAUNCHED\" or \"NOT_STARTED\" -rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified if -keepgoing is also specified) -rebuild-db : bring the database schema up to date - -rollup N : fill run (set by :runname) with latest test(s) from - past N days, requires keys + -rollup : fill run (set by :runname) with latest test(s) from + prior runs with same keys -rename-run : rename run (set by :runname) to , requires keys -update-meta : update the tests metadata for all tests Helpers -runstep stepname ... : take remaining params as comand and execute as stepname @@ -303,11 +303,11 @@ (general-run-call "-rollup" "rollup tests" (lambda (db keys keynames keyvallst) (let ((n (args:get-arg "-rollup"))) - (runs:rollup db keys keynames keyvallst n))))) + (runs:rollup-run db keys))))) ;;====================================================================== ;; run one test ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -120,10 +120,56 @@ (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (car results))))))))) +;; get the previous record for when this test was run where all keys match but runname +;; NB// Merge this with test:get-previous-test-run-records +(define (test:get-matching-previous-test-run-records db run-id test-name item-path) + (let* ((keys (db:get-keys db)) + (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) + (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (keyvals #f) + (tests-hash (make-hash-table))) + ;; first look up the key values from the run selected by run-id + (sqlite3:for-each-row + (lambda (a . b) + (set! keyvals (cons a b))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (if (not keyvals) + #f + (let ((prev-run-ids '())) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + ;; collect all matching tests for the runs then + ;; extract the most recent test and return that. + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) #f ;; no previous runs? return #f + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (db-get-tests-for-run db hed test-name item-path))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name + ", item-path " item-path " results: " (intersperse results "\n")) + ;; Keep only the youngest of any test/item combination + (for-each + (lambda (testdat) + (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) + (stored-test (hash-table-ref/default tests-hash full-testname #f))) + (if (or (not stored-test) + (and stored-test + (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) + ;; this test is younger, store it in the hash + (hash-table-set! tests-hash full-testname testdat)))) + results) + (if (null? tal) + (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests + (loop (car tal)(cdr tal)))))))))) (define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) (let* ((real-status status) (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) (otherdat (if dat dat (make-hash-table))) @@ -682,14 +728,16 @@ (runs (vector-ref rundat 1))) (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) "/"))) + (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) + (dirs-to-remove (make-hash-table))) (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 (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")) (for-each (lambda (test) @@ -699,23 +747,45 @@ (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))) - )) - ))) + (hash-table-set! dirs-to-remove fullpath #t) + ;; The following was the safe delete code but it was not being exectuted. + ;; (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))) + + ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records + ;; for each test in case we get killed. That should minimize the detritus left on disk + ;; process the dirs from longest string length to shortest + (for-each + (lambda (dir-to-remove) + (if (file-exists? dir-to-remove) + (let ((dir-in-db '())) + (sqlite3:for-each-row + (lambda (dir) + (set! dir-in-db (cons dir dir-in-db))) + db "SELECT rundir FROM tests WHERE rundir LIKE ?;" + (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db + (if (null? dir-in-db) + (begin + (debug:print 2 "Removing directory with zero db references: " dir-to-remove) + (system (conc "rm -rf " dir-to-remove)) + (hash-table-delete! dirs-to-remove dir-to-remove)) + (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database"))))) + (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b))))) + + ;; remove the run if zero tests remain (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)) @@ -794,13 +864,49 @@ ;; read configs with tricks turned off (i.e. no system) (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) (runs:update-test_meta db test-name test-conf))) test-names))) -(define (runs:rollup-run db keys keynames keyvallst n) +;; This could probably be refactored into one complex query ... +(define (runs:rollup-run db keys) (let* ((new-run-id (register-run db keys)) - (similar-runs (db:get-runs db keys)) - (tests-n-days (db:get-tests-n-days db similar-runs))) + (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) + (curr-tests (db-get-tests-for-run db new-run-id "%" "%")) + (curr-tests-hash (make-hash-table))) + ;; index the already saved tests by testname and itempath in curr-tests-hash + (for-each + (lambda (testdat) + (let* ((testname (db:test-get-testname testdat)) + (item-path (db:test-get-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 (test-id) - (db:rollup-test db run-id test-id)) - tests-n-days))) + (lambda (testdat) + (let* ((testname (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (full-name (conc testname "/" item-path)) + (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) + (test-steps (db:get-steps-for-test db (db:test-get-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,value,expected_value,tol,units,first_err,first_warn) " + "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);") + new-run-id (cddr (vector->list testdat))) + (set! new-testdat (car (db-get-tests-for-run db new-run-id 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)) + (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)) + )) + prev-tests))) + + Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -1,17 +1,21 @@ (use test) ;; (require-library args) +(include "../megatest.scm") (include "../common.scm") (include "../keys.scm") (include "../db.scm") (include "../configf.scm") (include "../process.scm") (include "../launch.scm") (include "../items.scm") (include "../runs.scm") +(include "../runconfig.scm") (include "../megatest-version.scm") + +(define test-work-dir (current-directory)) (define conffile #f) (test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) @@ -33,11 +37,11 @@ (string? (getenv "MT_RUN_AREA_HOME")))) (test "open-db" #t (begin (set! *db* (open-db)) (if *db* #t #f))) -;; quit wasting time changing db to *db* +;; quit wasting time, I'm changing *db* to db (define db *db*) (test "get cpu load" #t (number? (get-cpu-load))) (test "get uname" #t (string? (get-uname))) @@ -74,10 +78,11 @@ (list "-h") args:arg-hash 0)) (test "register-run" #t (number? (register-run *db* (db-get-keys *db*)))) +(define keys (db-get-keys *db*)) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" (setenv "BLAHFOO" "1234") (unsetenv "NADAFOO") (test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) @@ -95,5 +100,42 @@ (test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) (set! *verbosity* 1) (test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) (test "Items table empty items I" '() (item-table->item-list '(("A")))) (test "Items table empty items II" '() (item-table->item-list '(("A" "")))) + +;; Test out the steps code + +(define test-id #f) + +;; force keepgoing +; (hash-table-set! args:arg-hash "-keepgoing" #t) +(hash-table-set! args:arg-hash "-itempatt" "%") +(hash-table-set! args:arg-hash "-testpatt" "%") +(test "Setup for a run" #t (begin (setup-for-run) #t)) +(test "Remove the rollup run" #t (begin (remove-runs) #t)) +(test "Run a test" #t (general-run-call + "-runtests" + "run a test" + (lambda (db keys keynames keyvallst) + (let ((test-names '("runfirst"))) + (run-tests db test-names))))) + +(change-directory test-work-dir) +(test "Add a step" #t + (begin + (teststep-set-status! db 1 "runfirst" "firststep" "start" 0 '() "This is a comment") + (sleep 2) + (teststep-set-status! db 1 "runfirst" "firststep" "end" "pass" '() "This is a different comment") + (set! test-id (db:test-get-id (car (db-get-tests-for-run db 1 "runfirst" "")))) + (number? test-id))) + +(test "Get nice table for steps" "2.0s" + (begin + (vector-ref (hash-table-ref (db:get-steps-table db test-id) "firststep") 4))) + +(hash-table-set! args:arg-hash ":runname" "rollup") + +(test "Remove the rollup run" #t (begin (remove-runs) #t)) +(test "Rollup the run(s)" #t (begin + (runs:rollup-run db keys) + #t))