Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -978,32 +978,26 @@ ;; if the test is not found then clearly the waiton is not met... (if (not ever-seen)(set! result (cons waitontest-name result))))) waitons) (delete-duplicates result)))) -(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile) - (debug:print 4 "run-id: " run-id " test-name: " test-name) +(define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile) + (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) (let* ((state (check-valid-items "state" state-in)) - (status (check-valid-items "status" status-in)) - (testdat (db:get-test-info db run-id test-name item-path))) - (debug:print 5 "testdat: " testdat) - (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. - (or (not state)(not status))) + (status (check-valid-items "status" status-in))) + (if (or (not state)(not status)) (debug:print 0 "WARNING: Invalid " (if status "status" "state") - " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if testdat - (let ((test-id (test:get-id testdat))) - (mutex-lock! *incoming-mutex*) - (set! *incoming-data* (cons (vector 'step-status - (current-seconds) - ;; FIXME - this should not update the logfile unless it is specified. - (list test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))) - *incoming-data*)) - (mutex-unlock! *incoming-mutex*) - (if (not *cache-on*)(db:write-cached-data db)) - #t) - (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (mutex-lock! *incoming-mutex*) + (set! *incoming-data* (cons (vector 'step-status + (current-seconds) + ;; FIXME - this should not update the logfile unless it is specified. + (list test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))) + *incoming-data*)) + (mutex-unlock! *incoming-mutex*) + (if (not *cache-on*)(db:write-cached-data db)) + #t)) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== @@ -1139,18 +1133,18 @@ (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:set-tests-state-status host port) run-id testnames currstate currstatus newstate newstatus)) (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) -(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) +(define (rdb:teststep-set-status! db test-id teststep-name state-in status-in itemdat comment logfile) (let ((item-path (item-list->path itemdat))) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:teststep-set-status! host port) - run-id test-name teststep-name state-in status-in item-path comment logfile)) - (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)))) + test-id teststep-name state-in status-in item-path comment logfile)) + (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile)))) (define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) (let ((item-path (item-list->path itemdat))) (if *runremote* (let ((host (vector-ref *runremote* 0)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -53,10 +53,11 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) @@ -185,11 +186,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rdb:teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f) + (rdb:teststep-set-status! db test-id stepname "start" "-" itemdat #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -203,11 +204,11 @@ (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) - (rdb:teststep-set-status! db run-id test-name stepname "end" exinfo itemdat #f logfna)) + (rdb:teststep-set-status! db test-id stepname "end" exinfo itemdat #f logfna)) (if logpro-used (test-set-log! db run-id test-name itemdat (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -434,11 +435,11 @@ ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (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*) - (let ((useshell (config-lookup *configdat* "jobtools" "useshell")) + (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")) (memory (config-lookup test-conf "requirements" "memory")) @@ -460,12 +461,15 @@ (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) - (mt-bindir-path #f)) - (if hosts (set! hosts (string-split hosts))) + (mt-bindir-path #f) + (item-path (item-list->path itemdat)) + (testinfo (rdb:get-test-info db run-id test-name item-path)) + (test-id (db:test-get-id testinfo))) + (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (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 @@ -483,10 +487,11 @@ (write (list (list 'testpath test-path) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) + (list 'test-id test-id ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -564,10 +564,11 @@ (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (logfile (args:get-arg "-setlog"))) @@ -578,11 +579,11 @@ (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (and state status) - (rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) + (rdb:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) @@ -603,10 +604,11 @@ (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) @@ -644,11 +646,11 @@ ((zsh bash sh ash) "2>&1 >"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (rdb:teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) + (rdb:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) ;; close the db (sqlite3:finalize! db) ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) @@ -668,11 +670,11 @@ (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (rdb:test-set-log! db run-id test-name itemdat htmllogfile))) - (rdb:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile) + (rdb:teststep-set-status! db test-id stepname "end" exitstat itemdat (args:get-arg "-m") logfile) (sqlite3:finalize! db) (if (not (eq? exitstat 0)) (exit 254)) ;; (exit exitstat) doesn't work?!? ;; open the db ;; mark the end of the test Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -66,12 +66,12 @@ (lambda (run-id testnames currstate currstatus newstate newstatus) (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) (rpc:publish-procedure! 'rdb:teststep-set-status! - (lambda (run-id test-name teststep-name state-in status-in item-path comment logfile) - (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))) + (lambda (test-id teststep-name state-in status-in item-path comment logfile) + (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile))) (rpc:publish-procedure! 'rdb:test-update-meta-info (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree)))