Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1017,19 +1017,22 @@
(let loop ((start-time (current-time)))
(thread-sleep! 0.5) ;; move save time around to minimize regular collisions?
(db:write-cached-data)
(loop start-time)))
-(define (cdb:test-set-state-status test-id status state)
+(define (cdb:test-set-status-state test-id status state #!key (msg #f))
(debug:print 4 "INFO: Adding status/state to queue: " status "/" state)
(mutex-lock! *incoming-mutex*)
- (set! *incoming-data* (cons (vector 'state-status
- (current-seconds)
- (list state
- status
- test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree)
- *incoming-data*))
+ (if msg
+ (set! *incoming-data* (cons (vector 'state-status-msg
+ (current-seconds)
+ (list state status msg test-id))
+ *incoming-data*))
+ (set! *incoming-data* (cons (vector 'state-status
+ (current-seconds)
+ (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree)
+ *incoming-data*)))
(mutex-unlock! *incoming-mutex*)
(if *cache-on*
(debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
(db:write-cached-data)))
@@ -1052,14 +1055,15 @@
;; values to be applied
;;
(define (db:write-cached-data)
(open-run-close
(lambda (db . params)
- (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"))
- (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;"))
- (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f)
- (data #f))
+ (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"))
+ (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;"))
+ (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;"))
+ (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f)
+ (data #f))
(mutex-lock! *incoming-mutex*)
(set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
(set! *incoming-data* '())
(mutex-unlock! *incoming-mutex*)
(if (> (length data) 0)
@@ -1074,16 +1078,19 @@
(apply sqlite3:execute meta-stmt (vector-ref entry 2)))
((step-status)
(apply sqlite3:execute step-stmt (vector-ref entry 2)))
((state-status)
(apply sqlite3:execute state-status-stmt (vector-ref entry 2)))
+ ((state-status-msg)
+ (apply sqlite3:execute state-status-msg-stmt (vector-ref entry 2)))
(else
(debug:print 0 "ERROR: Queued entry not recognised " entry))))
data)))
(sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the statements asap?
(sqlite3:finalize! step-stmt)
(sqlite3:finalize! state-status-stmt)
+ (sqlite3:finalize! state-status-msg-stmt)
))
#f))
;; (define (db:write-cached-data db)
;; (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"))
@@ -1122,11 +1129,11 @@
"UPDATE tests
SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
WHERE run_id=? AND testname=? AND item_path='';"
run-id test-name run-id test-name run-id test-name)
- (thread-sleep! 0.1) ;; give other processes a chance here
+ ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP?
(if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
(sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name)
(sqlite3:execute
db
"UPDATE tests
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -40,16 +40,23 @@
;; given an exit code and whether or not logpro was used calculate OK/BAD
;; return #t if we are ok, #f otherwise
(define (steprun-good? logpro exitcode)
(or (eq? exitcode 0)
(and logpro (eq? exitcode 2))))
+
+;; if handed a string, process it, else look for MT_CMDINFO
+(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
+ (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
+ (if enccdm
+ (read (open-input-string (base64:base64-decode enccmd)))
+ '())))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd)))))
(setenv "MT_CMDINFO" encoded-cmd)
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
- ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
+ ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo))
(top-path (assoc/default 'toppath cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
@@ -107,11 +114,11 @@
(alist->env-vars env-ovrd)
(open-run-close set-megatest-env-vars #f run-id)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
(open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0)
- (open-run-close tests:test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
+ (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript (not (file-execute-access? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
;; We are about to actually kick off the test
@@ -125,11 +132,11 @@
(job-thread #f)
(runit (lambda ()
;; (let-values
;; (((pid exit-status exit-code)
;; (run-n-wait fullrunscript)))
- (open-run-close tests:test-set-status! #f test-id "RUNNING" "n/a" #f #f)
+ (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
(let loop ((i 0))
(let-values
@@ -198,12 +205,12 @@
(thread-sleep! 2)
(processloop (+ i 1))))
))
(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)
- (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna))
+ ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
+ (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna))
(if logpro-used
(open-run-close db:test-set-log! #f 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)
@@ -223,23 +230,23 @@
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
;; NB// test-set-status! does rdb calls under the hood
- (open-run-close tests:test-set-status! #f test-id "RUNNING" "WARN"
- (if (eq? this-step-status 'warn) "Logpro warning found" #f)
- #f))
+ (tests:test-set-status! test-id "RUNNING" "WARN"
+ (if (eq? this-step-status 'warn) "Logpro warning found" #f)
+ #f))
((pass)
- (open-run-close tests:test-set-status! #f test-id "RUNNING" "PASS" #f #f))
+ (tests:test-set-status! test-id "RUNNING" "PASS" #f #f))
(else ;; 'fail
(set! rollup-status 1) ;; force fail
- (open-run-close tests:test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
+ (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(loop (car tal) (cdr tal) stepname)))
- (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
+ (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
(monitorjob (lambda ()
(let* ((start-seconds (current-seconds))
(calc-minutes (lambda ()
(inexact->exact
(round
@@ -271,12 +278,12 @@
(system (conc "kill -9 " p-id))))))
(car processes))
(system (conc "kill -9 " pid))))
(begin
(debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
- (open-run-close tests:test-set-status! #f test-id "KILLED" "FAIL"
- (args:get-arg "-m") #f)
+ (tests:test-set-status! test-id "KILLED" "FAIL"
+ (args:get-arg "-m") #f)
(sqlite3:finalize! tdb)
(exit 1))))
(set! kill-tries (+ 1 kill-tries))
(mutex-unlock! m)))
;; (sqlite3:finalize! db)
@@ -292,23 +299,23 @@
(let* ((item-path (item-list->path itemdat))
(testinfo (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path)))
(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(begin
(debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
- (open-run-close tests:test-set-status! #f test-id
- (if kill-job? "KILLED" "COMPLETED")
- (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"))
- ((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"))
- (args:get-arg "-m") #f)))
+ (tests:test-set-status! test-id
+ (if kill-job? "KILLED" "COMPLETED")
+ (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"))
+ ((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"))
+ (args:get-arg "-m") #f)))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
(open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no
)
(mutex-unlock! m)
@@ -399,11 +406,11 @@
(toptest-path (conc disk-path "/" testtop-base))
(test-path (conc disk-path "/" test-base))
;; ensure this exists first as links to subtests must be created there
(linktree (let ((rd (config-lookup *configdat* "setup" "linktree")))
- (if rd rd (conc *toppath* "/runs"))))
+ (if rd rd (conc *toppath* "/runs"))))
(lnkbase (conc linktree "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))
@@ -491,16 +498,16 @@
;; (launch-test db (cadr status) test-conf))
(define (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat params)
(change-directory *toppath*)
(alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
(list ;; (list "MT_TEST_RUN_DIR" work-area)
- (list "MT_RUN_AREA_HOME" *toppath*)
- (list "MT_TEST_NAME" test-name)
- ;; (list "MT_ITEM_INFO" (conc itemdat))
- (list "MT_RUNNAME" runname)
- ;; (list "MT_TARGET" mt_target)
- ))
+ (list "MT_RUN_AREA_HOME" *toppath*)
+ (list "MT_TEST_NAME" test-name)
+ ;; (list "MT_ITEM_INFO" (conc itemdat))
+ (list "MT_RUNNAME" runname)
+ ;; (list "MT_TARGET" mt_target)
+ ))
(let* ((useshell (config-lookup *configdat* "jobtools" "useshell"))
(launcher (config-lookup *configdat* "jobtools" "launcher"))
(runscript (config-lookup test-conf "setup" "runscript"))
(ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big
(diskspace (config-lookup test-conf "requirements" "diskspace"))
@@ -566,11 +573,11 @@
(list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " "))))
;; clean out step records from previous run if they exist
(debug:print 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
(open-run-close db:delete-test-step-records db test-id)
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
- (open-run-close tests:test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
+ (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(cond
((and launcher hosts) ;; must be using ssh hostname
(set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
(launcher
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -716,14 +716,14 @@
(not status)))
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
;; (sqlite3:finalize! db)
(exit 6)))
- (let ((msg (args:get-arg "-m")))
- ;; Convert to rpc
- ;; (rdb:open-run-close 'tests:test-set-status! #f test-id state newstatus msg otherdata))))
- (tests:test-set-status! db test-id state newstatus msg otherdata))))
+ (let* ((msg (args:get-arg "-m"))
+ (numoth (length (hash-table-keys otherdata))))
+ ;; Convert to rpc inside the tests:test-set-status! call, not here
+ (tests:test-set-status! test-id state newstatus msg otherdata))))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t))))
;;======================================================================
;; Various helper commands can go below here
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -655,11 +655,11 @@
(if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
(db:test-get-run_duration testdat)))
600) ;; i.e. no update for more than 600 seconds
(begin
(debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
- (open-run-close tests:test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
+ (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
(debug:print 2 "NOTE: " test-name " is already running")))
(else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))))
;;======================================================================
;; END OF NEW STUFF
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -70,14 +70,14 @@
(debug:print 4 "INFO: rdb:open-run-close " procname " " remargs)
(set! *last-db-access* (current-seconds))
(apply open-run-close (eval procname) remargs)))
(rpc:publish-procedure!
- 'cdb:test-set-state-status
+ 'cdb:test-set-status-state
(lambda (test-id status state)
- (debug:print 4 "INFO: cdb:test-set-state-status " procname " " remargs)
- (apply cdb:test-set-state-status remargs)))
+ (debug:print 4 "INFO: cdb:test-set-status-state " procname " " remargs)
+ (apply cdb:test-set-status-state remargs)))
;;======================================================================
;; end of publish-procedure section
;;======================================================================
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -111,21 +111,22 @@
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
;; Do not rpc this one, do the underlying calls!!!
-(define (tests:test-set-status! db test-id state status comment dat)
- (let* ((real-status status)
+(define (tests:test-set-status! test-id state status comment dat)
+ (let* ((db #f)
+ (real-status status)
(otherdat (if dat dat (make-hash-table)))
(testdat (open-run-close db:get-test-info-by-id db test-id))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-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
(waived (if (equal? status "FAIL")
- (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path)))
+ (let ((prev-test (open-run-close test:get-previous-test-run-record db run-id test-name item-path)))
(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)))
(debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
@@ -139,11 +140,11 @@
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
;; (rdb:open-run-close 'cdb:test-set-state-status #f test-id real-status state)) ;; this one works
- (cdb:test-set-state-status test-id real-status state))
+ (cdb:test-set-status-state test-id real-status state))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, do not rpc it (yet)
(if (and test-id state status (equal? status "AUTO"))
(open-run-close db:test-data-rollup db test-id status))
@@ -202,10 +203,11 @@
;; 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 #f))
+ ;; This query finds the path and changes the directory to it for the test
(sqlite3:for-each-row
(lambda (path final_logf)
(set! logf final_logf)
(if (directory? path)
(begin
@@ -438,30 +440,5 @@
#f)
(define (test:archive-tests db keynames target)
#f)
-;;======================================================================
-;; R P C
-;;======================================================================
-
-(define (rtests:register-test db run-id test-name item-path)
- (if *runremote*
- (let ((host (vector-ref *runremote* 0))
- (port (vector-ref *runremote* 1)))
- ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path))
- (tests:register-test db run-id test-name item-path)))
-
-(define (rtests:test-set-status! db test-id state status comment dat)
- (if *runremote*
- (let ((host (vector-ref *runremote* 0))
- (port (vector-ref *runremote* 1)))
- ((rpc:procedure 'rtests:test-set-status! host port) test-id state status comment dat))
- (tests:test-set-status! db test-id state status comment dat)))
-
-(define (rtests:test-set-toplog! db run-id test-name logf)
- (if *runremote*
- (let ((host (vector-ref *runremote* 0))
- (port (vector-ref *runremote* 1)))
- ((rpc:procedure 'rtests:test-set-toplog! host port) run-id test-name logf))
- (tests:test-set-toplog! db run-id test-name logf)))
-