Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -127,14 +127,14 @@ ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; TESTS - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) + ((test-set-state-status-by-id) (apply db:test-state-status-by-id-set! dbstruct params)) ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) + ((test-set-status-state) (apply db:test-status-state-set! dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) ;; ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) @@ -181,27 +181,27 @@ ((get-keys) (db:get-keys dbstruct)) ((get-key-vals) (apply db:get-key-vals dbstruct params)) ((get-targets) (db:get-targets dbstruct)) ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + ((test-get-archive-block-info) (apply db:test-archive-block-info dbstruct params)) ;; TESTS ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-rundir-from-test-id dbstruct params)) ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((test-get-logfile-info) (apply db:test-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-records-for-index-file dbstruct params)) ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((test-get-top-process-pid) (apply db:test-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((synchash-get) (apply synchash:server-get dbstruct params)) ;; RUNS Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -125,17 +125,17 @@ ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) - (let* ((item-path (db:test-get-item-path test-dat)) - (test-name (db:test-get-testname test-dat)) - (test-id (db:test-get-id test-dat)) - (run-id (db:test-get-run_id test-dat)) + (let* ((item-path (db:test-item-path test-dat)) + (test-name (db:test-testname test-dat)) + (test-id (db:test-id test-dat)) + (run-id (db:test-run_id test-dat)) (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) - (toplevel/children (and (db:test-get-is-toplevel test-dat) + (toplevel/children (and (db:test-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (mutex-lock! rp-mutex) @@ -198,12 +198,12 @@ (debug:print-info 0 "Archiving data with bup") (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix) ;; (mutex-unlock! bup-mutex) (for-each (lambda (test-dat) - (let ((test-id (db:test-get-id test-dat)) - (run-id (db:test-get-run_id test-dat))) + (let ((test-id (db:test-id test-dat)) + (run-id (db:test-run_id test-dat))) (rmt:test-set-archive-block-id run-id test-id archive-id) (if (member archive-command '("save-remove")) (runs:remove-test-directory test-dat 'archive-remove)))) (hash-table-ref test-groups disk-group)))) (hash-table-keys disk-groups)) @@ -219,18 +219,18 @@ ;; (for-each (lambda (test-dat) ;; When restoring test-dat will initially contain an old and invalid path to the test (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk. - (item-path (db:test-get-item-path test-dat)) - (test-name (db:test-get-testname test-dat)) - (test-id (db:test-get-id test-dat)) - (run-id (db:test-get-run_id test-dat)) + (item-path (db:test-item-path test-dat)) + (test-name (db:test-testname test-dat)) + (test-id (db:test-id test-dat)) + (run-id (db:test-run_id test-dat)) (keyvals (rmt:get-key-val-pairs run-id)) (target (string-intersperse (map cadr keyvals) "/")) - (toplevel/children (and (db:test-get-is-toplevel test-dat) + (toplevel/children (and (db:test-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory @@ -239,11 +239,11 @@ ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) - (archive-block-id (db:test-get-archived test-dat)) + (archive-block-id (db:test-archived test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))) @@ -274,11 +274,11 @@ ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/ ;; DO BUP RESTORE (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id)) (new-test-path (if (vector? new-test-dat ) - (db:test-get-rundir new-test-dat) + (db:test-rundir new-test-dat) (begin (debug:print 0 "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) (exit 1)))) ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /.. (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -67,35 +67,35 @@ "Test date: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" - (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-testname testdat))) + (iup:label (db:test-testname testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-testname testdat))) (store-label "item-path" - (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-item-path testdat))) + (iup:label (db:test-item-path testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-item-path testdat))) (store-label "teststate" - (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") + (iup:label (db:test-state testdat) #:expand "HORIZONTAL") (lambda (testdat) - (db:test-get-state testdat))) - (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) + (db:test-state testdat))) + (let ((lbl (iup:label (db:test-status testdat) #:expand "HORIZONTAL"))) (hash-table-set! widgets "teststatus" (lambda (testdat) - (let ((newstatus (db:test-get-status testdat)) + (let ((newstatus (db:test-status testdat)) (oldstatus (iup:attribute lbl "TITLE"))) (if (not (equal? oldstatus newstatus)) (begin - (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) - (db:test-get-status testdat)))) - (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-state testdat) + (db:test-status testdat)))) + (iup:attribute-set! lbl "TITLE" (db:test-status testdat))))))) lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") (lambda (testdat) - (let ((newcomment (db:test-get-comment testdat))) + (let ((newcomment (db:test-comment testdat))) (if *dashboard-comment-share-slot* (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") newcomment)) (iup:attribute-set! *dashboard-comment-share-slot* "VALUE" @@ -103,16 +103,16 @@ newcomment))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) - (db:test-get-id testdat))) + (db:test-id testdat))) (store-label "testdate" (iup:label "TestDate " #:expand "HORIZONTAL") (lambda (testdat) - (seconds->work-week/day-time (db:test-get-event_time testdat)))) + (seconds->work-week/day-time (db:test-event_time testdat)))) ))))) ;;====================================================================== ;; Test meta panel ;;====================================================================== @@ -157,11 +157,11 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel db keydat testdat runname) - (let* ((run-id (db:test-get-run_id testdat)) + (let* ((run-id (db:test-run_id testdat)) (rundat (db:get-run-info db run-id)) (header (db:get-header rundat)) (event_time (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "event_time"))) @@ -206,32 +206,32 @@ (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" (iup:label ;; (sdb:qry 'getstr - (db:test-get-host testdat) ;; ) + (db:test-host testdat) ;; ) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-host testdat))) + (lambda (testdat)(db:test-host testdat))) (store-label "DiskFree" - (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-diskfree testdat)))) + (iup:label (conc (db:test-diskfree testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-diskfree testdat)))) (store-label "CPULoad" - (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-cpuload testdat)))) + (iup:label (conc (db:test-cpuload testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-cpuload testdat)))) (store-label "RunDuration" - (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") - (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) + (iup:label (conc (seconds->hr-min-sec (db:test-run_duration testdat))) #:expand "HORIZONTAL") + (lambda (testdat)(conc (seconds->hr-min-sec (db:test-run_duration testdat))))) (store-label "LogFile" - (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-final_logf testdat)))) + (iup:label (conc (db:test-final_logf testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-final_logf testdat)))) (store-label "ProcessId" - (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-process_id testdat)))) + (iup:label (conc (db:test-process_id testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-process_id testdat)))) (store-label "Uname" (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") (lambda (testdat) ;; (sdb:qry 'getstr - (db:test-get-uname testdat))) ;; ) + (db:test-uname testdat))) ;; ) ))))) ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) @@ -249,12 +249,12 @@ ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) - (let* ((state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) + (let* ((state (db:test-state testdat)) + (status (db:test-status testdat)) (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) (define *dashboard-test-db* #t) @@ -275,11 +275,11 @@ (let ((txtbox (iup:textbox #:action (lambda (val a b) (rmt:test-set-state-status-by-id run-id test-id #f #f b) ;; IDEA: Just set a variable with the proc to call? (rmt:test-set-state-status-by-id run-id test-id #f #f b) (set! newcomment b)) - #:value (db:test-get-comment testdat) + #:value (db:test-comment testdat) #:expand "HORIZONTAL"))) (set! wtxtbox txtbox) txtbox)) (apply iup:hbox @@ -287,11 +287,11 @@ (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (rmt:test-set-state-status-by-id run-id test-id state #f #f) - (db:test-set-state! testdat state))))) + (db:test-state-set! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each @@ -320,11 +320,11 @@ (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin (rmt:test-set-state-status-by-id run-id test-id #f status #f) - (db:test-set-status! testdat status)))))))) + (db:test-status-set! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each @@ -378,34 +378,34 @@ (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) ))) - #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:value (if ovrdval ovrdval (db:test-comment testdat)) #:expand "HORIZONTAL")) (dlog #f)) (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title "SET WAIVER" (iup:vbox ; #:expand "YES" (iup:label (conc "Enter justification for waiving test " - (db:test-get-testname testdat) - (if (equal? (db:test-get-item-path testdat) "") + (db:test-testname testdat) + (if (equal? (db:test-item-path testdat) "") "" - (conc "/" (db:test-get-item-path testdat))))) + (conc "/" (db:test-item-path testdat))))) wmesg ;; the informational msg on whether it matches comnt (iup:hbox (iup:button "Apply and Close " #:expand "HORIZONTAL" #:action (lambda (obj) (let ((comment (iup:attribute comnt "VALUE")) - (test-id (db:test-get-id testdat))) + (test-id (db:test-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (db:test-set-status! testdat "WAIVED") + (db:test-status-set! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" #:action (lambda (obj) @@ -425,11 +425,11 @@ (request-update #t)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) - (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (let* (;; (run-id (if testdat (db:test-run_id testdat) #f)) (test-registry (tests:get-all)) (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) (rundat (if testdat (rmt:get-run-info run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) @@ -437,16 +437,16 @@ ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat - (db:test-get-rundir testdat) + (db:test-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (tests:get-compressed-steps #f run-id test-id) '())) - (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) - (testname (if testdat (db:test-get-testname testdat) "n/a")) + (testfullname (if testdat (db:test-fullname testdat) "Gathering data ...")) + (testname (if testdat (db:test-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) @@ -455,11 +455,11 @@ (map (lambda (keyval) ;; (conc ":" (car keyval) " " (cadr keyval))) (cadr keyval)) keydat) "/")) - (item-path (db:test-get-item-path testdat)) + (item-path (db:test-item-path testdat)) ;; this next block was added to fix a bug where variables were ;; needed. Revisit this. (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) (if (file-exists? runconfigf) (handle-exceptions @@ -470,12 +470,12 @@ (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn - (tests:get-testconfig (db:test-get-testname testdat) test-registry #f) - (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) + (tests:get-testconfig (db:test-testname testdat) test-registry #f) + (tests:get-testconfig (db:test-testname testdat) test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dashboard-tests:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) @@ -517,14 +517,14 @@ ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (tests:get-compressed-steps #f run-id test-id)) - (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) + (set! logfile (conc (db:test-rundir testdat) "/" (db:test-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* - (db:test-get-rundir testdat)) ;; ) - (set! testfullname (db:test-get-fullname testdat)) + (db:test-rundir testdat)) ;; ) + (set! testfullname (db:test-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ... ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same ;; (set! db-mod-time (+ curr-mod-time 1)) @@ -534,11 +534,11 @@ (set! db-mod-time curr-mod-time)) (set! last-update (current-milliseconds)) (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (db:test-testname-set! testdat "DEAD OR DELETED TEST"))) (if need-update (begin ;; update the gui elements here (for-each (lambda (key) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -216,16 +216,16 @@ (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) (define (compare-tests test1 test2) - (let* ((test-name1 (db:test-get-testname test1)) - (item-path1 (db:test-get-item-path test1)) - (eventtime1 (db:test-get-event_time test1)) - (test-name2 (db:test-get-testname test2)) - (item-path2 (db:test-get-item-path test2)) - (eventtime2 (db:test-get-event_time test2)) + (let* ((test-name1 (db:test-testname test1)) + (item-path1 (db:test-item-path test1)) + (eventtime1 (db:test-event_time test1)) + (test-name2 (db:test-testname test2)) + (item-path2 (db:test-item-path test2)) + (eventtime2 (db:test-event_time test2)) (same-name (equal? test-name1 test-name2)) (test1-top (equal? item-path1 "")) (test2-top (equal? item-path2 "")) (test1-older (> eventtime1 eventtime2)) (same-time (equal? eventtime1 eventtime2))) @@ -388,12 +388,12 @@ ;; (define (get-itemized-tests test-dats) (let ((tnames '())) (for-each (lambda (tdat) - (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) - (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (let ((tname (db:test-testname tdat)) ;; (db:test-get-testname tdat)) + (ipath (db:test-item-path tdat) ) ) ;; (db:test-get-item-path tdat))) (if (not (equal? ipath "")) (if (and (list? tnames) (string? tname) (not (member tname tnames))) (set! tnames (append tnames (list tname))))))) @@ -410,12 +410,12 @@ (let* ((tnames '()) ;; list of names used to reserve order (tests (make-hash-table)) ;; hash of lists, used to build as we go (itemized (get-itemized-tests test-dats))) (for-each (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + (let* ((tname (db:test-testname tdat)) ;; (db:test-get-testname tdat)) + (ipath (db:test-item-path tdat))) ;; (db:test-get-item-path tdat))) ;; (seen (hash-table-ref/default tests tname #f))) (if (not (member tname tnames)) (if (or (and (eq? priority 'itempath) (not (equal? ipath ""))) (and (eq? priority 'testname) @@ -510,17 +510,17 @@ (lambda (x)(equal? (test:test-get-fullname x) testname)) testsdat))) (if (null? matching) (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") (car matching)))) - (testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test)) + (testname (db:test-testname test)) + (itempath (db:test-item-path test)) (testfullname (test:test-get-fullname test)) - (teststatus (db:test-get-status test)) - (teststate (db:test-get-state test)) - ;;(teststart (db:test-get-event_time test)) - ;;(runtime (db:test-get-run_duration test)) + (teststatus (db:test-status test)) + (teststate (db:test-state test)) + ;;(teststart (db:test-event_time test)) + ;;(runtime (db:test-run_duration test)) (buttontxt (cond ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) ((and (equal? teststate "NOT_STARTED") (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) teststatus) @@ -1452,12 +1452,12 @@ #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (test-id (db:test-id (vector-ref buttndat 3))) + (run-id (db:test-run_id (vector-ref buttndat 3))) (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1043,11 +1043,11 @@ ;;====================================================================== ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived -;; +;; BB: db:archive-get-allocations not used anywhere. (define (db:archive-get-allocations dbstruct testname itempath dneeded) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space @@ -1140,11 +1140,11 @@ (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; -(define (db:test-get-archive-block-info dbstruct archive-block-id) +(define (db:test-archive-block-info dbstruct archive-block-id) (db:with-db dbstruct #f #f (lambda (db) @@ -1220,12 +1220,12 @@ (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) + ;; (> (- (current-seconds)(+ (db:test-event_time testdat) + ;; (db:test-run_duration testdat))) ;; 600) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") @@ -1279,12 +1279,12 @@ (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) + ;; (> (- (current-seconds)(+ (db:test-event_time testdat) + ;; (db:test-run_duration testdat))) ;; 600) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") @@ -2067,10 +2067,13 @@ (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) prev-run-ids))) + + + ;;====================================================================== ;; T E S T S ;;====================================================================== @@ -2086,10 +2089,11 @@ '()) (let* ((qryvalstr (case qryvals ((shortlist) "id,run_id,testname,item_path,state,status") ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") (else qryvals))) + (qryfields (string-split qryvalstr ",")) (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " @@ -2136,60 +2140,97 @@ (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + ;; BB: vec->defstruct refactor replaces: + ;;(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + (set! res + (cons + (alist->db:test (map cons qryfields (cons a b))) + res))) db qry run-id ))) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res))))) + ;; (case qryvals + ;; ((shortlist)(map db:test-short-record->norm res)) + ;; ((#f) res) + ;; (else res))))) + (if (eq? qryvals shortlist) + (for-each (lambda (inrec) (db:test-short-record->norm inrec)) res)) + res))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" - ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (vector (vector-ref inrec 0) ;; id - (vector-ref inrec 1) ;; run_id - (vector-ref inrec 2) ;; testname - (vector-ref inrec 4) ;; state - (vector-ref inrec 5) ;; status - -1 "" -1 -1 "" "-" - (vector-ref inrec 3) ;; item-path - -1 "-" "-")) + ;; "id,run_id,testname,state,status, event_time,host,cpuload,diskfree,uname,rundir, item_path, run_duration,final_logf,comment + + (db-test-event_time-set! inrec -1) + (db-test-host-set! inrec "") + (db-test-cpuload-set! inrec -1) + (db-test-diskfree-set! inrec -1) + (db-test-uname-set! inrec "") + (db-test-rundir-set! inrec "-") + (db-test-run_duration-set! inrec "-") + (db-test-final_logf-set! inrec "-") + (db-test-comment-set! inrec "-") + + ;; (vector (vector-ref inrec 0) ;; id + ;; (vector-ref inrec 1) ;; run_id + ;; (vector-ref inrec 2) ;; testname + ;; (vector-ref inrec 4) ;; state + ;; (vector-ref inrec 5) ;; status + ;; -1 "" -1 -1 "" "-" + ;; (vector-ref inrec 3) ;; item-path + ;; -1 "-" "-") + + ) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (qryfields '(id testname item_path state,status)) + (qryfields-str (string-join (map ->string qryfields) "," )) + (qry (conc "SELECT " qryfields-str " FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) - db + (let ((1res make-db:test)) + (db:test-id-set! 1res id) + (db:test-testname-set! 1res testname) + (db:test-item_path-set! 1res item-path) + (db:test-state-set! 1res state) + (db:test-status-set! 1res status) + (db:test-short-record->norm 1res) + (set! res (cons 1res res)))) + ;;(set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db qry run-id))) res)) (define (db:get-testinfo-state-status dbstruct run-id test-id) - (let ((res #f)) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (run-id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) - db - "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" - test-id))) + (let* ((res #f) + (qryfields '(id testname item_path state,status)) + (qryfields-str (string-join (map ->string qryfields) "," ))) + (db:with-db + dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (make-db:test + id: test-id run_id: run-id testname: testname state: state status: status + event_time: -1 host: "" cpuload: -1 diskfree: -1 uname: "" rundir: "-" item_path: item-path + run_duration: -1 final_logf: "-" comment: "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintest-get-{id ,run_id,testname ...} ;; @@ -2415,11 +2456,11 @@ #f (lambda (db) (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;" pid test-id)))) -(define (db:test-get-top-process-pid dbstruct run-id test-id) +(define (db:test-top-process-pid dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) @@ -2535,13 +2576,17 @@ run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) + ;; BB: replaced following vec construction with db:test defstruct + ;; (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) +;; (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) + + (lambda (a . b) + (set! res (alist->db:test (map cons db:test-record-fields (cons a b))))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -2556,11 +2601,12 @@ (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (apply vector a b) res))) + (set! res (cons (alist->db:test (map cons db:test-record-fields (cons a b))) res ))) + ;;BB: replaced vec with defstruct above -- (set! res (cons (apply vector a b) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) @@ -2571,17 +2617,19 @@ #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) - (set! res (apply vector a b))) + (set! res (alist->db:test (map cons db:test-record-fields (cons a b))))) + ;; BB: replaced following vec construction with db:test defstruct + ;;(set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") test-name item-path) res)))) -(define (db:test-get-rundir-from-test-id dbstruct run-id test-id) +(define (db:test-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) @@ -2757,19 +2805,19 @@ keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + ;; (debug:print 8 "db:test-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) row-ids)) -(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) +(define (db:test-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id @@ -2870,11 +2918,11 @@ ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) ;; #f) ;; ))) -(define (db:test-get-logfile-info dbstruct run-id test-name) +(define (db:test-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id #f (lambda (db) @@ -3150,15 +3198,15 @@ (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))) + (let* ((full-testname (conc (db:test-testname testdat) "/" (db:test-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)))) + (> (db:test-event_time testdat)(db:test-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 @@ -3201,11 +3249,11 @@ (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) -(define (db:test-get-records-for-index-file dbstruct run-id test-name) +(define (db:test-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct run-id #f @@ -3344,14 +3392,14 @@ (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (let* ((state (db:test-get-state test)) - (status (db:test-get-status test)) - (item-path (db:test-get-item-path test)) + ;; (if (equal? waitontest-name (db:test-testname test)) ;; by defintion this had better be true ... + (let* ((state (db:test-state test)) + (status (db:test-status test)) + (item-path (db:test-item-path test)) (is-completed (equal? state "COMPLETED")) (is-running (equal? state "RUNNING")) (is-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) ;; testname-b path-a path-b Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -57,67 +57,76 @@ ; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) ;; constructor for dbstruct ;; -(define (actual-make-dbr:dbstruct #!key (path #f)(local #f)) - (make-dbr:dbstruct path: path local: local locdbs: (make-hash-table))) - -(define (dbr:dbstruct-get-localdb v run-ids) - (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) - -(define (dbr:dbstruct-set-localdb! v run-id db) - (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) - - -(define (make-db:test)(make-vector 20)) -(define-inline (db:test-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) -(define-inline (db:test-get-testname vec) (vector-ref vec 2)) -(define-inline (db:test-get-state vec) (vector-ref vec 3)) -(define-inline (db:test-get-status vec) (vector-ref vec 4)) -(define-inline (db:test-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:test-get-host vec) (vector-ref vec 6)) -(define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) -(define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) -(define-inline (db:test-get-uname vec) (vector-ref vec 9)) -;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) -(define-inline (db:test-get-rundir vec) (vector-ref vec 10)) -(define-inline (db:test-get-item-path vec) (vector-ref vec 11)) -(define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) -(define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) -(define-inline (db:test-get-comment vec) (vector-ref vec 14)) -(define-inline (db:test-get-process_id vec) (vector-ref vec 16)) -(define-inline (db:test-get-archived vec) (vector-ref vec 17)) + +;; BB: commenting out following 3 methods since they are unused +;; (define (actual-make-dbr:dbstruct #!key (path #f)(local #f)) +;; (make-dbr:dbstruct path: path local: local locdbs: (make-hash-table))) + +;; (define (dbr:dbstruct-get-localdb v run-ids) +;; (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) + +;; (define (dbr:dbstruct-set-localdb! v run-id db) +;; (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) + +(defstruct db:test id run_id testname state status event_time host cpuload + diskfree uname rundir item-path run_duration final_logf + comment process_id pass_count fail_count archived ) +;; BB: 16ww4.3 begin comment out +;; (define (make-db:test)(make-vector 20)) +;; (define-inline (db:test-get-id vec) (vector-ref vec 0)) +;; (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) +;; (define-inline (db:test-get-testname vec) (vector-ref vec 2)) +;; (define-inline (db:test-get-state vec) (vector-ref vec 3)) +;; (define-inline (db:test-get-status vec) (vector-ref vec 4)) +;; (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) +;; (define-inline (db:test-get-host vec) (vector-ref vec 6)) +;; (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) +;; (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) +;; (define-inline (db:test-get-uname vec) (vector-ref vec 9)) + +;; ;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) +;; (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) +;; (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) +;; (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) +;; (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) +;; (define-inline (db:test-get-comment vec) (vector-ref vec 14)) +;; (define-inline (db:test-get-process_id vec) (vector-ref vec 16)) +;; (define-inline (db:test-get-archived vec) (vector-ref vec 17)) +;; BB: 16ww4.3 end comment out ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) -(define-inline (db:test-get-fullname vec) - (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) +(define-inline (db:test-fullname struct) + (conc (db:test-testname struct) "/" (db:test-item-path struct))) ;; replace runs:make-full-test-name with this routine (define (db:test-make-full-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) -(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) - -(define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) -(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) -(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) -(define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) -(define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) -(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) -(define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) +;; BB: commenting out following unused items: +;(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) +;(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) +;;(define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) +;;(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) + +;; BB: commenting out methods replaced by defstruct +;; (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) +;; (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) +;; (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) +;; (define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) +;; (define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) ;; Test record utility functions ;; Is a test a toplevel? ;; -(define (db:test-get-is-toplevel vec) - (and (equal? (db:test-get-item-path vec) "") ;; test is not an item - (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run +(define (db:test-get-is-toplevel struct) + (and (equal? (db:test-item-path struct) "") ;; test is not an item + (equal? (db:test-uname struct) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -178,11 +178,11 @@ (colnum 1) (rownum 0)) ;; rownum = 0 is the header ;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) ;; tests related stuff - ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) + ;; (all-testnames (delete-duplicates (map db:test-testname test-changes)))) ;; Given a run-id and testname/item_path calculate a cell R:C ;; NOTE: Also build the test tree browser and look up table ;; Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -26,19 +26,19 @@ (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) (let* ((test-run-dir ;; (filedb:get-path *fdb* - (db:test-get-rundir testdat)) ;; ) + (db:test-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) (exit-info (vector #t #t #t)) - (test-id (db:test-get-id testdat)) - (run-id (db:test-get-run_id testdat)) - (test-name (db:test-get-testname testdat)) + (test-id (db:test-id testdat)) + (run-id (db:test-run_id testdat)) + (test-name (db:test-testname testdat)) (kill-job #f)) ;; for future use (on re-factoring with launch.scm code (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) (if (> count 0) @@ -139,29 +139,29 @@ (loop (car tal) (cdr tal) stepname runflag)))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; - (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) + (let* ((item-path (db:test-item-path testdat)) ;; (item-list->path itemdat)) (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? - (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (if (equal? (db:test-state testinfo) "RUNNING") ;; (not (equal? (db:test-state testinfo) "COMPLETED")) (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" - ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ;; (db:test-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + (if (equal? (db:test-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - (else "FAIL")))) ;; (db:test-get-status testinfo))) - (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) + (if (equal? (db:test-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + (else "FAIL")))) ;; (db:test-status testinfo))) + (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-state testinfo) "), updating result, rollup-status is " rollup-status) (tests:test-set-status! test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -271,17 +271,17 @@ ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) (cond - ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun + ((member (db:test-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running - ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) + ((not (member (db:test-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) - (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) - (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (else ;; (member (db:test-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) + (debug:print 0 "ERROR: test state is " (db:test-state test-info) ", cannot proceed") (exit)))) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process @@ -545,26 +545,26 @@ (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? - (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (if (member (db:test-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" - ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ;; (db:test-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond ((not (launch:einf-exit-status exit-info)) "FAIL") ;; job failed to run ... (vector-ref exit-info 1) ((eq? (launch:einf-rollup-status exit-info) 0) ;; (vector-ref exit-info 3) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + (if (equal? (db:test-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3) ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - (else "FAIL")))) ;; (db:test-get-status testinfo))) - (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) + (if (equal? (db:test-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + (else "FAIL")))) ;; (db:test-status testinfo))) + (debug:print-info 1 "Test exited in state=" (db:test-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f) @@ -801,11 +801,11 @@ (if (not (hash-table-ref/default *toptest-paths* testname #f)) (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo ;; (filedb:get-path *fdb* ;; (db:get-path dbstruct ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir testinfo) ;; ) ;; ) + (db:test-rundir testinfo) ;; ) ;; ) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) @@ -943,13 +943,13 @@ (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run - (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir + (not (member (db:test-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir (begin - (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) + (debug:print-info 0 "attempting to preclean directory " (db:test-rundir testinfo) " for test " test-name "/" item-path) (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1157,11 +1157,11 @@ ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* ;; (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (let ((steps (rmt:get-steps-for-test run-id (db:test-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -132,22 +132,22 @@ (define (mt:process-triggers run-id test-id newstate newstatus) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))) (if test-dat (let* ((test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* - (db:test-get-rundir test-dat)) ;; ) ;; ) - (test-name (db:test-get-testname test-dat)) + (db:test-rundir test-dat)) ;; ) ;; ) + (test-name (db:test-testname test-dat)) (tconfig #f) - (state (if newstate newstate (db:test-get-state test-dat))) - (status (if newstatus newstatus (db:test-get-status test-dat)))) + (state (if newstate newstate (db:test-state test-dat))) + (status (if newstatus newstatus (db:test-status test-dat)))) (if (and test-rundir ;; #f means no dir set yet (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) - (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) + (cons "MT_ITEMPATH" (db:test-item-path test-dat))) (lambda () (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let ((cmd (configf:lookup tconfig "triggers" trigger)) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -464,11 +464,11 @@ ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) - (run-id (db:test-get-run_id test-data)) + (run-id (db:test-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) run-id '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) @@ -493,32 +493,32 @@ (set! rownum (+ rownum 1)))) vals))) (list (list run-info-matrix (if test-id - (list (db:test-get-run_id test-data) + (list (db:test-run_id test-data) target runname "n/a") (make-list 4 ""))) (list test-info-matrix (if test-id (list test-id - (db:test-get-testname test-data) - (db:test-get-item-path test-data) - (db:test-get-state test-data) - (db:test-get-status test-data) - (seconds->string (db:test-get-event_time test-data)) - (db:test-get-comment test-data)) + (db:test-testname test-data) + (db:test-item-path test-data) + (db:test-state test-data) + (db:test-status test-data) + (seconds->string (db:test-event_time test-data)) + (db:test-comment test-data)) (make-list 7 ""))) (list test-run-matrix (if test-id - (list (db:test-get-host test-data) - (db:test-get-uname test-data) - (db:test-get-diskfree test-data) - (db:test-get-cpuload test-data) - (seconds->hr-min-sec (db:test-get-run_duration test-data))) + (list (db:test-host test-data) + (db:test-uname test-data) + (db:test-diskfree test-data) + (db:test-cpuload test-data) + (seconds->hr-min-sec (db:test-run_duration test-data))) (make-list 5 ""))) )) (dcommon:populate-steps steps-dat steps-matrix)))))) ;;(list meta-dat-matrix ;; (if test-id Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -30,10 +30,10 @@ (define-inline (test:get-state vec) (vector-ref vec 3)) (define-inline (test:get-status vec) (vector-ref vec 4)) (define-inline (test:get-item-path vec)(vector-ref vec 5)) (define-inline (test:test-get-fullname test) - (conc (db:test-get-testname test) - (if (equal? (db:test-get-item-path test) "") + (conc (db:test-testname test) + (if (equal? (db:test-item-path test) "") "" - (conc "(" (db:test-get-item-path test) ")")))) + (conc "(" (db:test-item-path test) ")")))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -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 @@ -612,14 +612,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))) @@ -677,11 +677,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") @@ -712,14 +712,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)))) @@ -745,11 +745,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)) @@ -896,11 +896,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) @@ -961,12 +961,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 @@ -1007,14 +1007,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)) @@ -1244,28 +1244,28 @@ (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) @@ -1275,20 +1275,20 @@ (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 @@ -1360,11 +1360,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*))) @@ -1458,12 +1458,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)) @@ -1597,37 +1597,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-get-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-get-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 @@ -1651,14 +1651,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))))) @@ -1666,11 +1666,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) @@ -1713,18 +1713,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))) @@ -1754,13 +1754,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 ;;====================================================================== @@ -1874,25 +1874,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) " @@ -1899,24 +1899,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))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -260,15 +260,15 @@ ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) - (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) + (testconfig (tests:get-testconfig (db:test-testname testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr - (db:test-get-rundir testdat)) ;; ) + (db:test-rundir testdat)) ;; ) (prev-rundir ;; (sdb:qry 'passstr - (db:test-get-rundir prev-testdat)) ;; ) + (db:test-rundir prev-testdat)) ;; ) (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) @@ -329,12 +329,12 @@ ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (rmt:get-test-info-by-id run-id test-id)) - (test-name (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) + (test-name (db:test-testname testdat)) + (item-path (db:test-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? @@ -343,13 +343,13 @@ (prev-test (if (equal? status "FAIL") (rmt:get-previous-test-run-record run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series - (let ((prev-status (db:test-get-status prev-test)) - (prev-state (db:test-get-state prev-test)) - (prev-comment (db:test-get-comment prev-test))) + (let ((prev-status (db:test-tatus prev-test)) + (prev-state (db:test-tate prev-test)) + (prev-comment (db:test-comment prev-test))) (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) (if (and (equal? prev-state "COMPLETED") (equal? prev-status "WAIVED")) (if comment comment @@ -631,17 +631,17 @@ ;; summarize test (define (tests:summarize-test run-id test-id) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (steps-dat (rmt:get-steps-for-test run-id test-id)) - (test-name (db:test-get-testname test-dat)) - (item-path (db:test-get-item-path test-dat)) + (test-name (db:test-testname test-dat)) + (item-path (db:test-item-path test-dat)) (full-name (db:test-make-full-name test-name item-path)) - (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) - (status (db:test-get-status test-dat)) + (oup (open-output-file (conc (db:test-rundir test-dat) "/test-summary.html"))) + (status (db:test-status test-dat)) (color (common:get-color-from-status status)) - (logf (db:test-get-final_logf test-dat)) + (logf (db:test-final_logf test-dat)) (steps-dat (tests:get-compressed-steps #f run-id test-id))) ;; (dcommon:get-compressed-steps #f 1 30045) ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) (s:output-new @@ -649,19 +649,19 @@ (s:html (s:title "Summary for " full-name) (s:body (s:h2 "Summary for " full-name) (s:table 'cellspacing "0" 'border "1" - (s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat)) - (s:td "test id") (s:td (db:test-get-id test-dat))) + (s:tr (s:td "run id") (s:td (db:test-run_id test-dat)) + (s:td "test id") (s:td (db:test-id test-dat))) (s:tr (s:td "testname") (s:td test-name) (s:td "itempath") (s:td item-path)) - (s:tr (s:td "state") (s:td (db:test-get-state test-dat)) + (s:tr (s:td "state") (s:td (db:test-state test-dat)) (s:td "status") (s:td (s:a 'href logf (s:font 'color color status)))) (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time - (db:test-get-event_time test-dat))) - (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) + (db:test-event_time test-dat))) + (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-run_duration test-dat))))) (s:h3 "Log files") (s:table 'cellspacing "0" 'border "1" (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) (s:table @@ -940,14 +940,14 @@ (test-id (rmt:get-test-id run-id test-name item-path)) (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status - (if (or (and (member (db:test-get-status tdat) + (if (or (and (member (db:test-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) - (equal? (db:test-get-state tdat) "COMPLETED")) - (member (db:test-get-state tdat) + (equal? (db:test-state tdat) "COMPLETED")) + (member (db:test-state tdat) '("INCOMPLETE" "KILLED"))) (set! keep-test #f)) ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list @@ -954,14 +954,14 @@ (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) - (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") - (member (db:test-get-status wtdat) '("FAIL" "ABORT"))) - (member (db:test-get-status wtdat) '("KILLED")) - (member (db:test-get-state wtdat) '("INCOMPETE"))) + (if (or (and (equal? (db:test-state wtdat) "COMPLETED") + (member (db:test-status wtdat) '("FAIL" "ABORT"))) + (member (db:test-status wtdat) '("KILLED")) + (member (db:test-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) ;; '("FAIL" "KILLED")) ;; (member (db:test-get-state wtdat) ;; '("INCOMPETE"))) (set! keep-test #f)))) ;; no point in running this one again Index: tests/unittests/dbrdbstruct.scm ================================================================== --- tests/unittests/dbrdbstruct.scm +++ tests/unittests/dbrdbstruct.scm @@ -4,16 +4,17 @@ ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) -(test #f #t (vector? (make-dbr:dbstruct "/tmp"))) +;; BB: 2016-01-20 suspect this file is dead code +(test #f #t (dbr:dbstruct? (make-dbr:dbstruct path: "/tmp"))) -(define dbstruct (make-dbr:dbstruct "/tmp")) +(define dbstruct (make-dbr:dbstruct path: "/tmp")) -(test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t)) -(test #f "blah" (dbr:dbstruct-get-main dbstruct)) +(test #f #t (begin (dbr:dbstruct-main-set! dbstruct "blah") #t)) +(test #f "blah" (dbr:dbstruct-main dbstruct)) (for-each (lambda (run-id) (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id)))) (list 1 2 3 4 5 6 7 8 9 #f)) Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -123,12 +123,12 @@ (test #f #t (number? (rmt:get-test-id 1 "rollup" "item/4"))) (define (get-state-status run-id testname itempath) (let ((tdat (rmt:get-test-info-by-id 1 (rmt:get-test-id run-id testname itempath)))) - (list (db:test-get-state tdat) - (db:test-get-status tdat)))) + (list (db:test-state tdat) + (db:test-status tdat)))) (test "Rollup PASS" '("COMPLETED" "PASS") (get-state-status 1 "rollup" "")) (let ((test-id (rmt:get-test-id 1 "rollup" "item/4")) (top-id (rmt:get-test-id 1 "rollup" ""))) (for-each @@ -233,11 +233,11 @@ (test "Add a step" #t (begin (rmt:teststep-set-status! 1 30002 "step1" "start" 0 "This is a comment" "mylogfile.html") (sleep 2) (rmt:teststep-set-status! 1 30002 "step1" "end" "pass" "This is a different comment" "finallogfile.html") - (set! test-id (db:test-get-id (car (mt:get-tests-for-run 1 "test1" '() '())))) + (set! test-id (db:test-id (car (mt:get-tests-for-run 1 "test1" '() '())))) (number? test-id))) (test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) (print "Rundir " rundir) (system (conc "mkdir -p " rundir)) @@ -320,11 +320,11 @@ (cdb:flush-queue *runremote*) (let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) (print "Setting " (length tests) " to COMPLETED/PASS") (for-each (lambda (test) - (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) + (cdb:test-set-status-state *runremote* (db:test-id test) "COMPLETED" "PASS" "Forced pass")) tests)) ;; (process-wait server-pid) ;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) ;; (print "Server ran for " run-delta " seconds")