Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -247,230 +247,234 @@
;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id) ;; run-id run-key origtest)
- (let* ((testdat (db:get-test-data-by-id db test-id))
- (run-id (if testdat (db:test-get-run_id testdat) #f))
- (keydat (if testdat (rdb:get-key-val-pairs db run-id) #f))
- (rundat (if testdat (rdb:get-run-info db run-id) #f))
- (runname (if testdat (db:get-value-by-header (db:get-row rundat)
- (db:get-header rundat)
- "runname") #f))
- ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f))
- (logfile "/this/dir/better/not/exist")
- (rundir logfile)
- (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
- (testname (if testdat (db:test-get-testname testdat) "n/a"))
- (testmeta (if testdat
- (let ((tm (rdb:testmeta-get-record db testname)))
- (if tm tm (make-db:testmeta)))
- (make-db:testmeta)))
-
- (keystring (string-intersperse
- (map (lambda (keyval)
- ;; (conc ":" (car keyval) " " (cadr keyval)))
- (cadr keyval))
- keydat)
- "/"))
- (item-path (db:test-get-item-path testdat))
- (viewlog (lambda (x)
- (if (file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (refreshdat (lambda ()
- (let ((newtestdat (rdb:get-test-data-by-id db test-id)))
- (if newtestdat
- (begin
- ;(mutex-lock! mx1)
- (set! testdat newtestdat)
- (set! teststeps (rdb:get-steps-for-test db test-id))
- (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
- (set! rundir (db:test-get-rundir testdat))
- (set! testfullname (db:test-get-fullname testdat))
- ;(mutex-unlock! mx1)
- )
- (begin
- (db:test-set-testname! testdat "DEAD OR DELETED TEST"))))))
- (widgets (make-hash-table))
- (meta-widgets (make-hash-table))
- (self #f)
- (store-label (lambda (name lbl cmd)
- (hash-table-set! widgets name
- (lambda (testdat)
- (let ((newval (cmd testdat))
- (oldval (iup:attribute lbl "TITLE")))
- (if (not (equal? newval oldval))
- (begin
- ;(mutex-lock! mx1)
- (iup:attribute-set! lbl "TITLE" newval)
- ;(mutex-unlock! mx1)
- )))))
- lbl))
- (store-meta (lambda (name lbl cmd)
- (hash-table-set! meta-widgets name
- (lambda (testmeta)
- (let ((newval (cmd testmeta))
- (oldval (iup:attribute lbl "TITLE")))
- (if (not (equal? newval oldval))
- (begin
- ;(mutex-lock! mx1)
- (iup:attribute-set! lbl "TITLE" newval)
- ;(mutex-unlock! mx1)
- )))))
- lbl))
- (store-button store-label)
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
- (command-launch-button (iup:button "Execute!" #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "megatest -runtests " testname " -target " keystring " :runname " runname
- " -itempatt " (if (equal? item-path "")
- "%"
- item-path)
- "" ))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "megatest -remove-runs -target " keystring " :runname " runname " -testpatt " testname " -itempatt "
- (if (equal? item-path "")
- "%"
- item-path)
- " -v ")))))
- (cond
- ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
- ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
- (else
- ;; (test-set-status! db run-id test-name state status itemdat)
- (set! self ;
- (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
- #:title testfullname
- (iup:vbox ; #:expand "YES"
- ;; The run and test info
- (iup:hbox ; #:expand "YES"
- (run-info-panel keydat testdat runname)
- (test-info-panel testdat store-label widgets)
- (test-meta-panel testmeta store-meta))
- (host-info-panel testdat store-label)
- ;; The controls
- (iup:frame #:title "Actions"
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "80x")
- (iup:button "Start Xterm" #:action xterm #:size "80x")
- (iup:button "Run Test" #:action run-test #:size "80x")
- (iup:button "Clean Test" #:action remove-test #:size "80x")
- (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
- (apply
- iup:hbox
- (list command-text-box command-launch-button))))
- (set-fields-panel test-id testdat)
- (iup:hbox
- (iup:frame
- #:title "Test Steps"
- (let ((stepsdat ;;(iup:label "Test steps ........................................."
- ;; #:expand "YES"
- ;; #:size "200x150"
- ;; #:alignment "ALEFT:ATOP")))
- (iup:textbox ;; #:action (lambda (obj char val)
- ;; #f)
- #:expand "YES"
- #:multiline "YES"
- #:font "Courier New, -10"
- #:size "60x100")))
- (hash-table-set! widgets "Test Steps"
- (lambda (testdat)
- (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE"))
- (fmtstr "~20a~10a~10a~12a~15a~20a")
- (comprsteps (rdb:get-steps-table db test-id))
- (newval (string-intersperse
- (append
- (list
- (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile")
- (format #f fmtstr "========" "=====" "===" "======" "====" "======="))
- (map (lambda (x)
- ;; take advantage of the \n on time->string
- (format #f fmtstr
- (vector-ref x 0)
- (let ((s (vector-ref x 1)))
- (if (number? s)(seconds->time-string s) s))
- (let ((s (vector-ref x 2)))
- (if (number? s)(seconds->time-string s) s))
- (vector-ref x 3) ;; status
- (vector-ref x 4)
- (vector-ref x 5))) ;; time delta
- (sort (hash-table-values comprsteps)
- (lambda (a b)
- (let ((time-a (vector-ref a 1))
- (time-b (vector-ref b 1)))
- (if (and (number? time-a)(number? time-b))
- (< time-a time-b)
- #t))))))
- "\n")))
- (if (not (equal? currval newval))
- (iup:attribute-set! stepsdat "VALUE" newval ))))) ;; "TITLE" newval)))))
- stepsdat))
- ;; populate the Test Data panel
- (iup:frame
- #:title "Test Data"
- (let ((test-data
- (iup:textbox ;; #:action (lambda (obj char val)
- ;; #f)
- #:expand "YES"
- #:multiline "YES"
- #:font "Courier New, -10"
- #:size "100x100")))
- (hash-table-set! widgets "Test Data"
- (lambda (testdat) ;;
- (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE"))
- (fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment
- (newval (string-intersperse
- (append
- (list
- (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment")
- (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "======="))
- (map (lambda (x)
- (format #f fmtstr
- (db:test-data-get-category x)
- (db:test-data-get-variable x)
- (db:test-data-get-value x)
- (db:test-data-get-expected x)
- (db:test-data-get-tol x)
- (db:test-data-get-status x)
- (db:test-data-get-units x)
- (db:test-data-get-type x)
- (db:test-data-get-comment x)))
- (db:read-test-data db test-id "%")))
- "\n")))
- (if (not (equal? currval newval))
- (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
- test-data)))
- )))
- (iup:show self)
- (iup:callback-set! *tim* "ACTION_CB"
- (lambda (x)
- ;; Now start keeping the gui updated from the db
- (refreshdat) ;; update from the db here
- ;(thread-suspend! other-thread)
- ;; update the gui elements here
- (for-each
- (lambda (key)
- ;; (print "Updating " key)
- ((hash-table-ref widgets key) testdat))
- (hash-table-keys widgets))
- (update-state-status-buttons testdat)
- ; (iup:refresh self)
- (if *exit-started*
- (set! *exit-started* 'ok))))))))
+ (let* ((testdat (db:get-test-data-by-id db test-id)))
+ (if (not testdat)
+ (begin
+ (debug:print 0 "ERROR: No test data found for test " test-id ", exiting")
+ (exit 1))
+ (let* ((run-id (if testdat (db:test-get-run_id testdat) #f))
+ (keydat (if testdat (rdb:get-key-val-pairs db run-id) #f))
+ (rundat (if testdat (rdb:get-run-info db run-id) #f))
+ (runname (if testdat (db:get-value-by-header (db:get-row rundat)
+ (db:get-header rundat)
+ "runname") #f))
+ ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f))
+ (logfile "/this/dir/better/not/exist")
+ (rundir logfile)
+ (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
+ (testname (if testdat (db:test-get-testname testdat) "n/a"))
+ (testmeta (if testdat
+ (let ((tm (rdb:testmeta-get-record db testname)))
+ (if tm tm (make-db:testmeta)))
+ (make-db:testmeta)))
+
+ (keystring (string-intersperse
+ (map (lambda (keyval)
+ ;; (conc ":" (car keyval) " " (cadr keyval)))
+ (cadr keyval))
+ keydat)
+ "/"))
+ (item-path (db:test-get-item-path testdat))
+ (viewlog (lambda (x)
+ (if (file-exists? logfile)
+ ;(system (conc "firefox " logfile "&"))
+ (iup:send-url logfile)
+ (message-window (conc "File " logfile " not found")))))
+ (xterm (lambda (x)
+ (if (directory-exists? rundir)
+ (let ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ "")))
+ (system (conc "cd " rundir
+ ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (message-window (conc "Directory " rundir " not found")))))
+ (refreshdat (lambda ()
+ (let ((newtestdat (rdb:get-test-data-by-id db test-id)))
+ (if newtestdat
+ (begin
+ ;(mutex-lock! mx1)
+ (set! testdat newtestdat)
+ (set! teststeps (rdb:get-steps-for-test db test-id))
+ (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
+ (set! rundir (db:test-get-rundir testdat))
+ (set! testfullname (db:test-get-fullname testdat))
+ ;(mutex-unlock! mx1)
+ )
+ (begin
+ (db:test-set-testname! testdat "DEAD OR DELETED TEST"))))))
+ (widgets (make-hash-table))
+ (meta-widgets (make-hash-table))
+ (self #f)
+ (store-label (lambda (name lbl cmd)
+ (hash-table-set! widgets name
+ (lambda (testdat)
+ (let ((newval (cmd testdat))
+ (oldval (iup:attribute lbl "TITLE")))
+ (if (not (equal? newval oldval))
+ (begin
+ ;(mutex-lock! mx1)
+ (iup:attribute-set! lbl "TITLE" newval)
+ ;(mutex-unlock! mx1)
+ )))))
+ lbl))
+ (store-meta (lambda (name lbl cmd)
+ (hash-table-set! meta-widgets name
+ (lambda (testmeta)
+ (let ((newval (cmd testmeta))
+ (oldval (iup:attribute lbl "TITLE")))
+ (if (not (equal? newval oldval))
+ (begin
+ ;(mutex-lock! mx1)
+ (iup:attribute-set! lbl "TITLE" newval)
+ ;(mutex-unlock! mx1)
+ )))))
+ lbl))
+ (store-button store-label)
+ (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
+ (command-launch-button (iup:button "Execute!" #:action (lambda (x)
+ (let ((cmd (iup:attribute command-text-box "VALUE")))
+ (system (conc cmd " &"))))))
+ (run-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "megatest -runtests " testname " -target " keystring " :runname " runname
+ " -itempatt " (if (equal? item-path "")
+ "%"
+ item-path)
+ "" ))))
+ (remove-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "megatest -remove-runs -target " keystring " :runname " runname " -testpatt " testname " -itempatt "
+ (if (equal? item-path "")
+ "%"
+ item-path)
+ " -v ")))))
+ (cond
+ ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
+ ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
+ (else
+ ;; (test-set-status! db run-id test-name state status itemdat)
+ (set! self ;
+ (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
+ #:title testfullname
+ (iup:vbox ; #:expand "YES"
+ ;; The run and test info
+ (iup:hbox ; #:expand "YES"
+ (run-info-panel keydat testdat runname)
+ (test-info-panel testdat store-label widgets)
+ (test-meta-panel testmeta store-meta))
+ (host-info-panel testdat store-label)
+ ;; The controls
+ (iup:frame #:title "Actions"
+ (iup:vbox
+ (iup:hbox
+ (iup:button "View Log" #:action viewlog #:size "80x")
+ (iup:button "Start Xterm" #:action xterm #:size "80x")
+ (iup:button "Run Test" #:action run-test #:size "80x")
+ (iup:button "Clean Test" #:action remove-test #:size "80x")
+ (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
+ (apply
+ iup:hbox
+ (list command-text-box command-launch-button))))
+ (set-fields-panel test-id testdat)
+ (iup:hbox
+ (iup:frame
+ #:title "Test Steps"
+ (let ((stepsdat ;;(iup:label "Test steps ........................................."
+ ;; #:expand "YES"
+ ;; #:size "200x150"
+ ;; #:alignment "ALEFT:ATOP")))
+ (iup:textbox ;; #:action (lambda (obj char val)
+ ;; #f)
+ #:expand "YES"
+ #:multiline "YES"
+ #:font "Courier New, -10"
+ #:size "60x100")))
+ (hash-table-set! widgets "Test Steps"
+ (lambda (testdat)
+ (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE"))
+ (fmtstr "~20a~10a~10a~12a~15a~20a")
+ (comprsteps (rdb:get-steps-table db test-id))
+ (newval (string-intersperse
+ (append
+ (list
+ (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile")
+ (format #f fmtstr "========" "=====" "===" "======" "====" "======="))
+ (map (lambda (x)
+ ;; take advantage of the \n on time->string
+ (format #f fmtstr
+ (vector-ref x 0)
+ (let ((s (vector-ref x 1)))
+ (if (number? s)(seconds->time-string s) s))
+ (let ((s (vector-ref x 2)))
+ (if (number? s)(seconds->time-string s) s))
+ (vector-ref x 3) ;; status
+ (vector-ref x 4)
+ (vector-ref x 5))) ;; time delta
+ (sort (hash-table-values comprsteps)
+ (lambda (a b)
+ (let ((time-a (vector-ref a 1))
+ (time-b (vector-ref b 1)))
+ (if (and (number? time-a)(number? time-b))
+ (< time-a time-b)
+ #t))))))
+ "\n")))
+ (if (not (equal? currval newval))
+ (iup:attribute-set! stepsdat "VALUE" newval ))))) ;; "TITLE" newval)))))
+ stepsdat))
+ ;; populate the Test Data panel
+ (iup:frame
+ #:title "Test Data"
+ (let ((test-data
+ (iup:textbox ;; #:action (lambda (obj char val)
+ ;; #f)
+ #:expand "YES"
+ #:multiline "YES"
+ #:font "Courier New, -10"
+ #:size "100x100")))
+ (hash-table-set! widgets "Test Data"
+ (lambda (testdat) ;;
+ (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE"))
+ (fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment
+ (newval (string-intersperse
+ (append
+ (list
+ (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment")
+ (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "======="))
+ (map (lambda (x)
+ (format #f fmtstr
+ (db:test-data-get-category x)
+ (db:test-data-get-variable x)
+ (db:test-data-get-value x)
+ (db:test-data-get-expected x)
+ (db:test-data-get-tol x)
+ (db:test-data-get-status x)
+ (db:test-data-get-units x)
+ (db:test-data-get-type x)
+ (db:test-data-get-comment x)))
+ (db:read-test-data db test-id "%")))
+ "\n")))
+ (if (not (equal? currval newval))
+ (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
+ test-data)))
+ )))
+ (iup:show self)
+ (iup:callback-set! *tim* "ACTION_CB"
+ (lambda (x)
+ ;; Now start keeping the gui updated from the db
+ (refreshdat) ;; update from the db here
+ ;(thread-suspend! other-thread)
+ ;; update the gui elements here
+ (for-each
+ (lambda (key)
+ ;; (print "Updating " key)
+ ((hash-table-ref widgets key) testdat))
+ (hash-table-keys widgets))
+ (update-state-status-buttons testdat)
+ ; (iup:refresh self)
+ (if *exit-started*
+ (set! *exit-started* 'ok))))))))))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1207,25 +1207,25 @@
(define (rdb:get-run-info db run-id)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:get-run-info host port) run-id))
- (db:get-run-info run-id)))
+ (db:get-run-info db run-id)))
(define (rdb:get-steps-for-test db test-id)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:get-steps-for-test host port) test-id))
- (db:get-steps-for-test test-id)))
+ (db:get-steps-for-test db test-id)))
(define (rdb:get-steps-table db test-id)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:get-steps-table host port) test-id))
- (db:get-steps-table test-id)))
+ (db:get-steps-table db test-id)))
(define (rdb:read-test-data db test-id categorypatt)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
@@ -1236,5 +1236,12 @@
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'rdb:get-test-info host port) run-id testname item-path))
(db:get-test-info db run-id testname item-path)))
+
+(define (rdb:delete-test-records db test-id)
+ (if *runremote*
+ (let ((host (vector-ref *runremote* 0))
+ (port (vector-ref *runremote* 1)))
+ ((rpc:procedure 'rdb:delete-test-records host port) test-id))
+ (db:delete-test-records db test-id)))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -285,11 +285,11 @@
(db:get-value-by-header run header x))
keynames) "/")
"/"
(db:get-value-by-header run header "runname"))
(let ((run-id (db:get-value-by-header run header "id")))
- (let ((tests (db-get-tests-for-run db run-id testpatt itempatt '() '())))
+ (let ((tests (rdb:get-tests-for-run db run-id testpatt itempatt '() '())))
;; Each test
(for-each
(lambda (test)
(format #t
" Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -488,11 +488,11 @@
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
(dirs-to-remove (make-hash-table)))
(let* ((run-id (db:get-value-by-header run header "id") )
- (tests (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
+ (tests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
(lasttpath "/does/not/exist/I/hope"))
(if (not (null? tests))
(begin
(debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
@@ -539,11 +539,11 @@
(hash-table-delete! dirs-to-remove dir-to-remove))
(debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
(sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))
;; remove the run if zero tests remain
- (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
+ (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
@@ -582,11 +582,11 @@
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
- (set! keys (db:get-keys db))
+ (set! keys (rdb:get-keys db))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
(runconfig (read-config runconfigf #f #f environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
@@ -649,11 +649,11 @@
(define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst
(debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
(let* (; (keyvalllst (keys:target->keyval keys target))
(new-run-id (runs:register-run db keys keyvallst runname "new" "n/a" user))
(prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
- (curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '()))
+ (curr-tests (rdb:get-tests-for-run db new-run-id "%" "%" '() '()))
(curr-tests-hash (make-hash-table)))
(db:update-run-event_time db new-run-id)
;; index the already saved tests by testname and itemdat in curr-tests-hash
(for-each
(lambda (testdat)
@@ -677,11 +677,11 @@
(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) "
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
new-run-id (cddr (vector->list testdat)))
- (set! new-testdat (car (db-get-tests-for-run db new-run-id testname item-path '() '())))
+ (set! new-testdat (car (rdb:get-tests-for-run db new-run-id testname item-path '() '())))
(hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table?
;; Now duplicate the test steps
(debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
(sqlite3:execute
db
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -180,10 +180,15 @@
(rpc:publish-procedure!
'rdb:get-test-info
(lambda (run-id testname item-path)
(db:get-test-info db run-id testname item-path)))
+ (rpc:publish-procedure!
+ 'rdb:delete-test-records
+ (lambda (test-id)
+ (db:delete-test-records db test-id)))
+
(set! *rpc:listener* rpc:listener)
(on-exit (lambda ()
(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
(sqlite3:finalize! db)))
(thread-start! th1)
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -52,11 +52,11 @@
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
- (let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
+ (let ((results (rdb:get-tests-for-run db hed test-name item-path '() '())))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
@@ -90,11 +90,11 @@
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
- (let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
+ (let ((results (rdb:get-tests-for-run db hed test-name item-path '() '())))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)