Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -106,11 +106,18 @@ (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " api:execute-requests/message: " + ((condition-property-accessor 'exn 'message "exn message null") exn) + " arguments: " + ((condition-property-accessor 'exn 'arguments "exn arguments null") exn) + " location: " + ((condition-property-accessor 'exn 'location "exn location null") exn) + + ) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t 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,59 +378,58 @@ (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) (iup:destroy! dlog))))))) dlog)) - ;;====================================================================== ;; ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") + (dbstruct (make-dbr:dbstruct-wrapper path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") local: #t)) (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (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) @@ -438,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))) @@ -456,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 @@ -471,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"))))) @@ -518,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)) @@ -535,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 @@ -90,11 +90,11 @@ (define *useserver* (or(not (args:get-arg "-use-local")) (configf:lookup *configdat* "dashboard" "use-server"))) (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* +(define *dbstruct-local* (make-dbr:dbstruct-wrapper path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) @@ -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 (or (db:test-testname test1) "")) + (item-path1 (or (db:test-item-path test1) "")) + (eventtime1 (db:test-event_time test1)) + (test-name2 (or (db:test-testname test2) "")) + (item-path2 (or (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 (vector-ref tdat 0)) ;; (db:test-testname tdat)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (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 (vector-ref testdat 0)) ;; (db:test-testname tdat)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref testdat 1))) ;; (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) @@ -508,19 +508,33 @@ (if buttondat (let* ((test (let ((matching (filter (lambda (x)(equal? (test:test-get-fullname x) testname)) testsdat))) (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (make-db:test id: -1 + run_id: -1 + testname: "" + state: "" + status: "" + event_time: 0 + host: "" + cpuload: "" + diskfree: 0 + uname: "" + rundir: "" + item-path: "" + run_duration: 0 + final_logf: "" + comment: "") (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 +1466,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 @@ -12,11 +12,12 @@ ;;====================================================================== ;; Database access ;;====================================================================== (require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n + md5 message-digest base64 format dot-locking z3 defstruct) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) @@ -41,15 +42,15 @@ ;; convert to -inline (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) + ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message "exn message null") exn) (if (eq? err-status 'done) default (begin - (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database @@ -87,28 +88,28 @@ (define (db:done-with dbstruct run-id mod-read) (if (not (sqlite3:database? dbstruct)) (begin (mutex-lock! *rundb-mutex*) (if (eq? mod-read 'mod) - (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds)) - (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) - (dbr:dbstruct-set-inuse! dbstruct #f) + (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) + (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) + (dbr:dbstruct-inuse-set! dbstruct #f) (mutex-unlock! *rundb-mutex*)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) - (let* ((dbdat (if (vector? dbstruct) + (let* ((dbdat (if (dbr:dbstruct? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; cheat, allow for passing in a dbdat (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (handle-exceptions exn (begin - (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) res)))) @@ -188,14 +189,14 @@ (sqlite3:open-database fname))))) ;; ) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((local (dbr:dbstruct-get-local dbstruct)) + (let* ((local (dbr:dbstruct-local dbstruct)) (rdb (if local - (dbr:dbstruct-get-localdb dbstruct run-id) - (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) + (dbr:dbstruct-localdb dbstruct run-id) + (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb (begin (mutex-lock! *rundb-mutex*) @@ -230,36 +231,36 @@ (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; only unset so other db's also can use this control - (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) - (dbr:dbstruct-set-inuse! dbstruct #t) - (dbr:dbstruct-set-olddb! dbstruct olddb) + (dbr:dbstruct-rundb-set! dbstruct (cons db dbpath)) + (dbr:dbstruct-inuse-set! dbstruct #t) + (dbr:dbstruct-olddb-set! dbstruct olddb) ;; (dbr:dbstruct-set-run-id! dbstruct run-id) (mutex-unlock! *rundb-mutex*) (if local (begin - (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... + (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... db) (begin - (dbr:dbstruct-set-inmem! dbstruct inmem) + (dbr:dbstruct-inmem-set! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context (db:sync-tables db:sync-tests-only db inmem) (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) + (dbr:dbstruct-refdb-set! dbstruct refdb) (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem))))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let ((mdb (dbr:dbstruct-get-main dbstruct))) + (let ((mdb (dbr:dbstruct-main dbstruct))) (if mdb mdb (begin (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path 0)) @@ -268,12 +269,12 @@ (olddb (db:open-megatest-db)) (write-access (file-write-access? dbpath)) (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - (dbr:dbstruct-set-main! dbstruct dbdat) - (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) + (dbr:dbstruct-main-set! dbstruct dbdat) + (dbr:dbstruct-olddb-set! dbstruct olddb) ;; olddb is already a (cons db path) (mutex-unlock! *rundb-mutex*) (if (and (not dbexists) *db-write-access*) ;; did not have a prior db and do have write access (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically dbdat))))) @@ -280,11 +281,11 @@ ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dbstruct (make-dbr:dbstruct path: dbdir local: local))) + (dbstruct (make-dbr:dbstruct-wrapper path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db) @@ -300,17 +301,17 @@ (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) - (stime (dbr:dbstruct-get-stime dbstruct)) - (rundb (dbr:dbstruct-get-rundb dbstruct)) - (inmem (dbr:dbstruct-get-inmem dbstruct)) - (maindb (dbr:dbstruct-get-main dbstruct)) - (refdb (dbr:dbstruct-get-refdb dbstruct)) - (olddb (dbr:dbstruct-get-olddb dbstruct)) + (let ((mtime (dbr:dbstruct-mtime dbstruct)) + (stime (dbr:dbstruct-stime dbstruct)) + (rundb (dbr:dbstruct-rundb dbstruct)) + (inmem (dbr:dbstruct-inmem dbstruct)) + (maindb (dbr:dbstruct-main dbstruct)) + (refdb (dbr:dbstruct-refdb dbstruct)) + (olddb (dbr:dbstruct-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) (debug:print-info 4 "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) (if (eq? run-id 0) @@ -322,11 +323,11 @@ force-sync) (begin (db:delay-if-busy maindb) (db:delay-if-busy olddb) (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. @@ -339,33 +340,33 @@ (> mtime stime) force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) ;; (mutex-unlock! *http-mutex*) num-synced) (begin ;; (mutex-unlock! *http-mutex*) 0)))))) (define (db:close-main dbstruct) - (let ((maindb (dbr:dbstruct-get-main dbstruct))) + (let ((maindb (dbr:dbstruct-main dbstruct))) (if maindb (begin (sqlite3:finalize! (db:dbdat-get-db maindb)) - (dbr:dbstruct-set-main! dbstruct #f))))) + (dbr:dbstruct-main-set! dbstruct #f))))) (define (db:close-run-db dbstruct run-id) (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) (if (and rdb (sqlite3:database? rdb)) (begin (sqlite3:finalize! rdb) - (dbr:dbstruct-set-localdb! dbstruct run-id #f) - (dbr:dbstruct-set-inmem! dbstruct #f))))) + (dbr:dbstruct-localdb-set! dbstruct run-id #f) + (dbr:dbstruct-inmem-set! dbstruct #f))))) ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db (db:sync-touched dbstruct 0 force-sync: #t) @@ -372,11 +373,11 @@ ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? (db:close-main dbstruct) - (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) + (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) (hash-table-keys locdbs)))) @@ -575,11 +576,11 @@ exn (begin (mutex-unlock! *db-sync-mutex*) (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) @@ -722,11 +723,11 @@ ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) (let* ((toppath (launch:setup-for-run)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) + (dbstruct (if toppath (make-dbr:dbstruct-wrapper path: toppath) #f)) (mtdb (if toppath (db:open-megatest-db))) (allow-cleanup (if run-ids #f #t)) (run-ids (if run-ids run-ids (if toppath (begin @@ -764,31 +765,31 @@ (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) (for-each (lambda (run-id) (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (dbstruct (if toppath (make-dbr:dbstruct-wrapper path: toppath local: #t) #f))) (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; (if (member 'new2old options) - (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) + (let* ((maindb (make-dbr:dbstruct-wrapper path: toppath local: #t)) (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) (count 1) (total (length all-run-ids)) (dead-runs '())) (for-each (lambda (run-id) (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) (set! count (+ count 1)) - (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + (let* ((fromdb (if toppath (make-dbr:dbstruct-wrapper path: toppath local: #t) #f)) (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) ;; (db:clean-up frundb) (if (eq? run-id 0) @@ -840,11 +841,11 @@ (case err-status ((busy) (thread-sleep! sleep-time)) (else (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message "exn message null") exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) @@ -1042,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 @@ -1219,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") @@ -1278,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") @@ -2066,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 ;;====================================================================== @@ -2085,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 " @@ -2135,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 ...} ;; @@ -2414,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) @@ -2429,10 +2471,12 @@ test-id)))) (define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time" "host" "cpuload" "diskfree" "uname" "rundir" "item_path" "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived")) + +(define db:test-record-fields-symbols (map string->symbol db:test-record-fields)) ;; fields *must* be a non-empty list ;; (define (db:field->number fieldname fields) (if (null? fields) @@ -2534,13 +2578,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-symbols (cons a b))))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -2555,11 +2603,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-symbols (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)))) @@ -2570,11 +2619,13 @@ #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-symbols (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)))) @@ -3030,13 +3081,13 @@ ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field )) - +;;BB: db:lookup-query - called by db:general-call (define (db:lookup-query qry-name) - (let ((q (alist-ref qry-name db:queries))) + (let ((q (alist-ref (if (string? qry-name) (string->symbol qry-name) qry-name) db:queries))) (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? @@ -3059,15 +3110,16 @@ (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) (define (db:general-call dbdat stmtname params) - (let ((query (let ((q (alist-ref (if (string? stmtname) - (string->symbol stmtname) - stmtname) - db:queries))) - (if q (car q) #f)))) + ;; (let ((query (let ((q (alist-ref (if (string? stmtname) + ;; (string->symbol stmtname) + ;; stmtname) + ;; db:queries))) + ;; (if q (car q) #f)))) + (let ((query (db:lookup-query stmtname))) (db:delay-if-busy dbdat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; get a summary of state and status counts to calculate a rollup @@ -3149,15 +3201,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 @@ -3343,14 +3395,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 @@ -13,108 +13,130 @@ ;; ;; ;; Accessors for a dbstruct ;; -(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) -(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) -(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) -(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) -(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) -(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) -(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) -(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) -(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) -;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) -;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) - -(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) -(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) -(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) -(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) -(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) -(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) -(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) -(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) -(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) -(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) -(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) -(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) -(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) -(define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) -(define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) +(use defstruct) + +(defstruct dbr:dbstruct main strdb path local rundb inmem mtime rtime stime inuse refdb locdbs olddb rundb-path) + +;; constructor for dbstruct +;; +(define (make-dbr:dbstruct-wrapper #!key (path #f)(local #f)) + (let ((res (make-dbr:dbstruct))) + (dbr:dbstruct-path-set! res path) + (dbr:dbstruct-local-set! res local) + (dbr:dbstruct-locdbs-set! res (make-hash-table)) + res)) + +;;; (define d1 (make-dbr:dbstruct)) +;;; (dbr:dbstruct-main d1) ==> retrive value +;;; (dbr:dbstruct-main-set! d1 'def) ==> set value + +;; (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) +;; (define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) +;; (define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) +;; (define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) +;; (define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) +;; (define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) +;; (define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) +;; (define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) +;; (define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) +;; ;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) +;; ;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) +;; ;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) +;; +;; (define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) +;; (define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) +;; (define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) +;; (define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) +;; (define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) +;; (define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) +;; (define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) +;; (define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) +;; (define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) +;; (define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) +;; (define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) +;; (define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) +;; (define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) +;; (define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) +;; (define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) ; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) ;; constructor for dbstruct ;; -(define (make-dbr:dbstruct #!key (path #f)(local #f)) - (let ((v (make-vector 15 #f))) - (dbr:dbstruct-set-path! v path) - (dbr:dbstruct-set-local! v local) - (dbr:dbstruct-set-locdbs! v (make-hash-table)) - v)) - -(define (dbr:dbstruct-get-localdb v run-id) - (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) - -(define (dbr:dbstruct-set-localdb! v run-id db) - (hash-table-set! (dbr:dbstruct-get-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-localdb v run-id) + (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) + +(define (dbr:dbstruct-localdb-set! 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: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -21,34 +21,42 @@ (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 (gutils:get-color-for-state-status state status);; #!key (get-label #f)) - ;; ((if get-label cadr car) - (case (string->symbol state) - ((COMPLETED) ;; ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 249 73" status)) - ((WARN WAIVED) (list "255 172 13" status)) - ((SKIP) (list "230 230 0" status)) - (else (list "253 33 49" status)))) - ((ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 170 73" status)) - ((WARN WAIVED) (list "200 130 13" status)) - ((SKIP) (list "180 180 0" status)) - (else (list "180 33 49" status)))) - ;; (if (equal? status "PASS") - ;; '("70 249 73" "PASS") - ;; (if (or (equal? status "WARN") - ;; (equal? status "WAIVED")) - ;; (list "255 172 13" status) - ;; (list "223 33 49" status)))) ;; greenish orangeish redish - ((LAUNCHED) (list "101 123 142" state)) - ((CHECK) (list "255 100 50" state)) - ((REMOTEHOSTSTART) (list "50 130 195" state)) - ((RUNNING) (list "9 131 232" state)) - ((KILLREQ) (list "39 82 206" state)) - ((KILLED) (list "234 101 17" state)) - ((NOT_STARTED) (list "240 240 240" state)) - (else (list "192 192 192" state)))) + (cond + ((not (string? state)) + (debug:print 0 "ERROR: gutils:get-color-for-state-status recieved non-string state " state) + (list "253 33 49" status)) + ((not (string? status)) + (debug:print 0 "ERROR: gutils:get-color-for-state-status recieved non-string status " status) + (list "253 33 49" status)) + (else + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) ;; ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list "230 230 0" status)) + (else (list "253 33 49" status)))) + ((ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 170 73" status)) + ((WARN WAIVED) (list "200 130 13" status)) + ((SKIP) (list "180 180 0" status)) + (else (list "180 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (list "240 240 240" state)) + (else (list "192 192 192" state)))))) 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 @@ -955,11 +955,11 @@ ;; IDEA: megatest list -runname blah% ... ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup-for-run) - (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) + (let* (;; (dbstruct (make-dbr:dbstruct-wrapper path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) @@ -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) @@ -1486,11 +1486,11 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (let ((dbstruct (make-dbr:dbstruct-wrapper path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) @@ -1792,11 +1792,11 @@ ;; fakeout readline (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) + (dbstruct (if toppath (make-dbr:dbstruct-wrapper path: toppath local: (args:get-arg "-local")) #f))) (if dbstruct (begin (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import extras) ;; might not be needed 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 @@ -84,11 +84,11 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* +(define *dbstruct-local* (make-dbr:dbstruct-wrapper path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) @@ -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: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -236,11 +236,11 @@ (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((dbstruct-local (if *dbstruct-db* *dbstruct-db* (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (db (make-dbr:dbstruct path: dbdir local: #t))) + (db (make-dbr:dbstruct-wrapper path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) (start (current-milliseconds)) 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 @@ -271,11 +271,12 @@ (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand) - (set-signal-handler! signal/stop sighand)) + ;; (set-signal-handler! signal/stop sighand) ;; should not be handling sigstop + ) (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (set! runconf (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (begin @@ -611,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))) @@ -676,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") @@ -711,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)))) @@ -744,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)) @@ -895,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) @@ -960,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 @@ -1006,16 +1007,16 @@ (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))))) + (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol (or st "#F=>BAD DATA")))))) tests-info) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) @@ -1154,15 +1155,14 @@ " ") "\n")) items))) (for-each (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (let* ((new-test-record (make-tests:testqueue)) + ;; (update-tests:testqueue test-record))) + (my-item-path (item-list->path my-itemdat))) + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! (let ((newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) @@ -1243,28 +1243,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) @@ -1274,20 +1274,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 @@ -1359,11 +1359,11 @@ (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) - (set! test-id (db:test-get-id testdat)) + (set! test-id (db:test-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") (change-directory *toppath*))) @@ -1457,12 +1457,12 @@ ((KILLED) (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) (debug:print 2 "NOTE: " test-name " is already running")) - ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) + ;; (if (> (- (current-seconds)(+ (db:test-event_time testdat) + ;; (db:test-run_duration testdat))) ;; (or incomplete-timeout ;; 6000)) ;; i.e. no update for more than 6000 seconds ;; (begin ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) @@ -1596,37 +1596,37 @@ ;; actions that operate on one test at a time can be handled below ;; (let ((sorted-tests (filter vector? (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr - (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) + (db:test-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-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 @@ -1650,14 +1650,14 @@ ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) @@ -1665,11 +1665,11 @@ (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal)))))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (mt:test-set-state-status-by-id run-id (db:test-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) @@ -1712,18 +1712,18 @@ ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) ) #t) (define (runs:remove-test-directory test mode) ;; remove-data-only) - (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree + (let* ((run-dir (db:test-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f))) (case mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) - ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "CLEANING" "LOCKED" #f)) + ((remove-all) (mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "REMOVING" "LOCKED" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) @@ -1753,13 +1753,13 @@ (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record (case mode - ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) - ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "NOT_STARTED" "n/a" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-run_id test)(db:test-id test) "ARCHIVED" #f #f)) + (else (rmt:delete-test-records (db:test-run_id test) (db:test-id test)))))) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== @@ -1873,25 +1873,25 @@ (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) - (let* ((testname (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) + (let* ((testname (db:test-testname testdat)) + (item-path (db:test-item-path testdat)) (full-name (conc testname "/" item-path))) (hash-table-set! curr-tests-hash full-name testdat))) curr-tests) ;; NOPE: Non-optimal approach. Try this instead. ;; 1. tests are received in a list, most recent first ;; 2. replace the rollup test with the new *always* (for-each (lambda (testdat) - (let* ((testname (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) + (let* ((testname (db:test-testname testdat)) + (item-path (db:test-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test (db:test-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " @@ -1898,24 +1898,24 @@ "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps - (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 "Copying records in test_steps from test_id=" (db:test-id testdat) " to " (db:test-id new-testdat)) (cdb:remote-run ;; to be replaced, note: this routine is not used currently (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " - "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") - (db:test-get-id testdat)) + "SELECT " (db:test-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") + (db:test-id testdat)) ;; Now duplicate the test data - (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 "Copying records in test_data from test_id=" (db:test-id testdat) " to " (db:test-id new-testdat)) (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " - "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") - (db:test-get-id testdat)))) + "SELECT " (db:test-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") + (db:test-id testdat)))) )) prev-tests))) 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/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -98,12 +98,11 @@ (set! test-one-id test-id) test-id)) (define test-one-rec #f) (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) (set! test-one-rec test-rec) - (vector-ref test-rec 2))) - + (db:test-testname test-rec))) ;; With data in db ;; (print "Using runame=" runname) (test #f '(1) (rmt:get-all-run-ids)) (test #f runname (rmt:get-run-name-from-id run-id)) 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-wrapper path: "/tmp"))) -(define dbstruct (make-dbr:dbstruct "/tmp")) +(define dbstruct (make-dbr:dbstruct-wrapper 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 @@ -10,11 +10,11 @@ "n/a" "bob"))) (test #f #t (rmt:register-test 1 "nada" "")) (test #f 30001 (rmt:get-test-id 1 "nada" "")) -(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info-by-id 1 30001) 3)) ;; "nada" "") 3)) +(test #f "NOT_STARTED" (db:test-state (rmt:get-test-info-by-id 1 30001))) ;; "nada" "") 3)) (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) (test #f "key2" (vector-ref (car (vector-ref (mt:get-runs-by-patt '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) @@ -119,16 +119,20 @@ (comment (conc "This is a comment for itempath " itempath))) ;; (rmt:test-set-state-status-by-id run-id test-id "COMPLETED" "PASS" comment) (tests:test-set-status! 1 test-id "COMPLETED" "PASS" comment #f))) ;; #!key (work-area #f)) '("item/1" "item/2" "item/3" "item/4" "item/5")) + +(exit) + + (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 +237,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 +324,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")