Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -21,23 +21,27 @@
((get-key-val-pairs) (apply db:get-key-val-pairs db params))
((get-keys) (db:get-keys db))
;; TESTS
;; json doesn't do vectors, convert to list
- ((get-test-info-by-id) (let ((res (apply db:get-test-info-by-id db params)))
- (if (vector? res)(vector->list res) res)))
- ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params))
- ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params)))
- ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params))
- ((get-count-tests-running) (db:get-count-tests-running db))
+ ((get-test-info-by-id) (let ((res (apply db:get-test-info-by-id db params)))
+ (if (vector? res)(vector->list res) res)))
+ ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params))
+ ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params)))
+ ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params))
+ ((get-count-tests-running) (db:get-count-tests-running db))
((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup db params))
- ((delete-test-records) (apply db:delete-test-records params))
+ ((delete-test-records) (apply db:delete-test-records params))
((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db))
- ((test-set-status-state) (apply db:test-set-status-state params))
- ((get-previous-test-run-record) (apply db:get-previous-test-run-record params))
+ ((test-set-status-state) (apply db:test-set-status-state params))
+ ((get-previous-test-run-record) (apply db:get-previous-test-run-record params))
((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params)))
-
+ ((db:test-get-logfile-info) (apply db:test-get-logfile-info db params))
+ ((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params)))
+ ((get-testinfo-state-status) (apply db:get-testinfo-state-status db params))
+ ((update-testdat-meta-info) (apply db:update-testdat-meta-info db params))
+
;; RUNS
((get-run-info) (let ((res (apply db:get-run-info db params)))
(list (vector-ref res 0)
(vector->list (vector-ref res 1)))))
((register-run) (apply db:register-run db params))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1315,19 +1315,10 @@
" run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;;(debug:print 0 "QRY: " qry)
(sqlite3:execute db qry run-id newstate newstatus testname testname)))
testnames))
-(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree)
- (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id))
-
-(define (cdb:tests-update-run-duration serverdat test-id minutes)
- (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id))
-
-(define (cdb:tests-update-uname-host serverdat test-id uname hostname)
- (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id))
-
;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
(cond
@@ -1339,10 +1330,19 @@
(if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))
(mt:process-triggers test-id newstate newstatus))
+(define (db:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
+ (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
+ (if (sqlite3:database? tdb)
+ (begin
+ (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
+ cpuload diskfree minutes)
+ (sqlite3:finalize! tdb))
+ (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
+
;; Never used, but should be?
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
state status run-id test-name item-path))
@@ -1532,13 +1532,10 @@
"SELECT rundir FROM tests WHERE id=?;"
test-id)
;; (hash-table-set! *test-paths* test-id res)
res)) ;; ))
-(define (cdb:test-set-log! serverdat test-id logf)
- (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id)))
-
;;======================================================================
;; Misc. test related queries
;;======================================================================
;; MUST BE CALLED local!
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -91,11 +91,11 @@
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
;; Setup the *runremote* global var
(if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
;; (set! *runremote* runremote)
;; (set! *transport-type* (string->symbol transport))
- (set! keys (cdb:remote-run db:get-keys #f))
+ (set! keys (rmt:get-keys))
(set! keyvals (keys:target->keyval keys target))
;; apply pre-overrides before other variables. The pre-override vars must not
;; clobbers things from the official sources such as megatest.config and runconfigs.config
(if (string? set-vars)
(let ((varpairs (string-split set-vars ",")))
@@ -255,11 +255,11 @@
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
(db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area))
(if logpro-used
- (cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
+ (rmt:test-set-log! test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
@@ -373,11 +373,11 @@
(thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
(mutex-lock! m)
(let* ((item-path (item-list->path itemdat))
;; only state and status needed - use lazy routine
- (testinfo (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
+ (testinfo (rmt:get-testinfo-state-status test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
;; 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"))
(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
@@ -503,11 +503,11 @@
(lnkbase (conc linktree "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))
;; Update the rundir path in the test record for all
- (cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf)
+ (rmt:general-call 'test-set-rundir-by-test-id test-id lnkpathf)
(debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
(debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
@@ -523,15 +523,15 @@
;; again.
;; NB - This is not working right - some top tests are not getting the path set!!!
(if (not (hash-table-ref/default *toptest-paths* testname #f))
- (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path))
+ (let* ((testinfo (rmt:get-test-info-by-id test-id)) ;; run-id testname item-path))
(curr-test-path (if testinfo (db:test-get-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?
- (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
+ (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(create-directory toptest-path #t)
@@ -672,11 +672,11 @@
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
(item-path (item-list->path itemdat))
;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
- (testinfo (cdb:get-test-info-by-id *runremote* test-id))
+ (testinfo (rmt:get-test-info-by-id test-id))
(mt_target (string-intersperse (map cadr keyvals) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
(if (args:get-arg "-logging")(list "-logging") '()))))
(setenv "MT_ITEMPATH" item-path)
(if hosts (set! hosts (string-split hosts)))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -135,10 +135,25 @@
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
(map list->vector
(rmt:send-receive 'get-matching-previous-test-run-records (list run-id test-name item-path))))
+(define (rmt:db:test-get-logfile-info run-id test-name)
+ (rmt:send-receive 'test-get-logfile-info (list run-id test-name)))
+
+(define (rmt:test-get-records-for-index-file run-id test-name)
+ (rmt:send-receive 'test-get-records-for-index-file (list run-id test-name)))
+
+(define (rmt:get-testinfo-state-status test-id)
+ (rmt:send-receive 'get-testinfo-state-status (list test-id)))
+
+(define (rmt:update-testdat-meta-info test-id work-area cpuload diskfree minutes)
+ (rmt:send-receive 'update-testdat-meta-info (list test-id work-area cpuload diskfree minutes)))
+
+(define (rmt:test-set-log! test-id logf)
+ (if (string? logf)(rmt:general-call 'test-set-log logf test-id)))
+
;; Statistical queries
(define (rmt:get-count-tests-running)
(rmt:send-receive 'get-count-tests-running '()))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -288,24 +288,23 @@
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
- (rmt:general-call 'set-test-comment cmt test-id)))
- ))
+ (rmt:general-call 'set-test-comment (list cmt test-id))))))
(define (tests:test-set-toplog! db run-id test-name logf)
- (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name))
+ (rmt:general-call 'tests:test-set-toplog logf run-id test-name))
(define (tests:summarize-items db run-id test-id test-name force)
;; if not force then only update the record if one of these is true:
;; 1. logf is "log/final.log
;; 2. logf is same as outputfilename
(let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
- (logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name))
+ (logf-info (rmt:test-get-logfile-info run-id test-name))
(logf (if logf-info (cadr logf-info) #f))
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(if (and (string? path)
(directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
@@ -327,11 +326,11 @@
(let ((oup (open-output-file outputfilename))
(counts (make-hash-table))
(statecounts (make-hash-table))
(outtxt "")
(tot 0)
- (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
+ (testdat (rmt:test-get-records-for-index-file run-id test-name)))
(with-output-to-port
oup
(lambda ()
(set! outtxt (conc outtxt "Summary: " test-name
"Summary for " test-name "
"))
@@ -466,12 +465,12 @@
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
- (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))
- (tdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (test-id (rmt:get-test-id run-id test-name item-path))
+ (tdat (rmt:get-testinfo-state-status 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)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
@@ -483,12 +482,12 @@
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
- (let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton ""))
- (wtdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
+ (wtdat (rmt:get-testinfo-state-status 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")))
(member (db:test-get-status wtdat) '("KILLED"))
(member (db:test-get-state wtdat) '("INCOMPETE")))
;; (if (or (member (db:test-get-status wtdat)
@@ -591,11 +590,11 @@
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
- (let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
+ (let* ((testdat (rmt:get-test-info-by-id test-id)))
(and testdat
(equal? (test:get-state testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
@@ -609,58 +608,36 @@
0)
(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)
;; This is a good candidate for threading the requests to enable
;; transactionized write at the server
- (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree)
+ (rmt:general-call 'update-cpuload-diskfree cpuload diskfree test-id)
(if minutes
- (cdb:tests-update-run-duration *runremote* test-id minutes))
+ (rmt:general-call 'update-run-duration minutes test-id))
(if (and uname hostname)
- (cdb:tests-update-uname-host *runremote* test-id uname hostname)))
+ (rmt:general-call 'update-uname-host uname hostname test-id)))
(define (tests:set-full-meta-info db test-id run-id minutes work-area)
;; DOES cdb:remote-run under the hood!
(let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
(cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
- (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
+ (rmt:update-testdat-meta-info test-id work-area cpuload diskfree minutes)
(tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)))
(define (tests:set-partial-meta-info db test-id run-id minutes work-area)
;; DOES cdb:remote-run under the hood!
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory))))
- (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
+ (rmt:update-testdat-meta-info test-id work-area cpuload diskfree minutes)
;; Update central with uname and hostname = #f
;; Is this one of the performance problems? This info should come from testdat-meta anyway
;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
))
-(define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
- cpuload diskfree minutes)
- (sqlite3:finalize! tdb))
- (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
-
-(define (tests:testdat-get-testinfo db test-id work-area)
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (res '()))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:for-each-row
- (lambda (update-time cpuload diskfree run-duration)
- (set! res (cons (vector update-time cpuload diskfree run-duration) res)))
- tdb
- "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY update_time ASC;")
- (sqlite3:finalize! tdb)))
- res))
-
;;======================================================================
;; A R C H I V I N G
;;======================================================================
(define (test:archive db test-id)