Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -88,20 +88,10 @@ (print "Failed to find megatest.config, exiting") (exit 1))) (define *dbstruct-local* (make-dbr:dbstruct path: *toppath* local: #t)) -;; (define sdb:qry (make-sdb:qry)) ;; 'init #f) - -;; (if (args:get-arg "-host") -;; (begin -;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) -;; (client:launch)) -;; (if (not (args:get-arg "-use-server")) -;; (set! *transport-type* 'fs) ;; force fs access -;; (client:launch))) - ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "db/main.db")))) ;; (client:setup *dbstruct-local*) (define toplevel #f) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -90,14 +90,10 @@ fulln runscript))))) ;; assume it is on the path (rollup-status 0)) (change-directory top-path) (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 (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) @@ -369,11 +365,11 @@ (thread-join! th1) (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. (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))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + (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")) (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 @@ -394,14 +390,10 @@ 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 ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! - ;; (if (not (equal? item-path "")) - ;; (begin - ;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority - ;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))) )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) @@ -500,11 +492,10 @@ (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 (filedb:register-path *fdb* lnkpathf)) (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path) (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 @@ -564,11 +555,10 @@ ;; (rmt:sdb-qry 'getstr (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 "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path) (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) (resolve-pathname lnkpath) lnkpath) testname "") @@ -700,11 +690,10 @@ (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) - ;; (list 'runremote *runremote*) (list 'transport (conc *transport-type*)) (list 'serverinf *server-info*) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -738,11 +738,10 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) - ;; (set! *runremote* runremote) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) @@ -786,11 +785,10 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) - ;; (set! *runremote* runremote) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) @@ -866,11 +864,10 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) - ;; (set! *runremote* runremote) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) @@ -915,11 +912,10 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) - ;; (set! *runremote* runremote) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) @@ -932,11 +928,10 @@ ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid logfname)))) (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") @@ -978,11 +973,10 @@ (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid htmllogfile)))) (rmt:test-set-log! run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") @@ -1185,23 +1179,13 @@ ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) -;; this is the socket if we are a client -;; (if (and *runremote* -;; (socket? *runremote*)) -;; (close-socket *runremote*)) - -;; (if sdb:qry (sdb:qry 'finalize #f)) -;; (if *fdb* (filedb:finalize-db! *fdb*)) - (if (not *didsomething*) (debug:print 0 help)) -;; (if *runremote* (rpc:close-all-connections!)) - (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0))