Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -112,11 +112,11 @@ update-run-event_time mark-incomplete set-state-status-and-roll-up-run ;; STEPS teststep-set-status! - + delete-steps-for-test ;; TEST DATA test-data-rollup csv->test-data ;; MISC @@ -216,11 +216,12 @@ ((set-var) (apply db:set-var dbstruct params)) ((del-var) (apply db:del-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - + ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) + ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) ;; MISC Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -103,11 +103,11 @@ (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 + (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 (case *transport-type* ((http)(http-transport:close-connections))) (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) (thread-sleep! 1) (client:setup-http areapath remaining-tries: (- remaining-tries 1)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -225,14 +225,52 @@ fullpath)) (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) +(define *common:logpro-exit-code->status-sym-alist* + '( ( 0 . pass ) + ( 1 . fail ) + ( 2 . warn ) + ( 3 . check ) + ( 4 . waived ) + ( 5 . abort ) + ( 6 . skip ))) +(define (common:logpro-exit-code->status-sym exit-code) + (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail)) +(define (common:worse-status-sym ss1 ss2) + (let loop ((status-syms-remaining '(abort fail check skip warn waived pass))) + (cond + ((null? status-syms-remaining) + 'fail) + ((eq? (car status-syms-remaining) ss1) + ss1) + ((eq? (car status-syms-remaining) ss2) + ss2) + (else + (loop (cdr status-syms-remaining)))))) +(define (common:steps-can-proceed-given-status-sym status-sym) + (if (member status-sym '(warn waived pass)) + #t + #f)) +(define (status-sym->string status-sym) + (case status-sym + ((pass) "PASS") + ((fail) "FAIL") + ((warn) "WARN") + ((check) "CHECK") + ((waived) "WAIVED") + ((abort) "ABORT") + ((skip) "SKIP") + (else "FAIL"))) + +(define (common:logpro-exit-code->test-status exit-code) + (status-sym->string (common:logpro-exit-code->status-sym exit-code))) (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive @@ -438,11 +476,11 @@ (if (not (directory-exists? "logs"))(create-directory "logs")) (directory-fold (lambda (file rem) (handle-exceptions exn - (debug:print-info 0 *default-log-port* "failed to rotate log " file ", probably handled by another process.") + (debug:print-info 0 *default-log-port* "unable to rotate log " file ", probably handled by another process.") (let* ((fullname (conc "logs/" file)) (file-age (- (current-seconds)(file-modification-time fullname)))) (if (or (and (string-match "^.*.log" file) (> (file-size fullname) 200000)) (and (string-match "^server-.*.log" file) @@ -890,11 +928,21 @@ ((dbr:dbstruct-read-only dbstruct) (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) (else (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (server:writable-watchdog dbstruct))) + (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync"))) + (cond + ((equal? syncer "brute-force-sync") + (server:writable-watchdog-bruteforce dbstruct)) + ((equal? syncer "delta-sync") + (server:writable-watchdog-deltasync dbstruct)) + (else + (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.") + (exit 1))) + ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") + ))) (debug:print-info 13 *default-log-port* "watchdog done.")) (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) (define (std-exit-procedure) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -771,11 +771,11 @@ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) - (dcommon:populate-steps teststeps steps-matrix)))) + (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -228,30 +228,29 @@ (if (not readyexists) (common:simple-file-lock-and-wait lockfname)) (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists) - (begin - (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) - (begin - (print "DEBUG: Setting tmp_mode for " fname) - (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) - ) - ) - (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) - (begin - (print "DEBUG: Setting nfs_mode for " fname) - (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) - ) - ) - (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) - (configf:lookup *configdat* "setup" "use-wal") - (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) - (initproc db))) + (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) + (begin + ;;(print "DEBUG: Setting tmp_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) + ) + ) + (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) + (begin + ;;(print "DEBUG: Setting nfs_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) + ) + ) + (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) + (configf:lookup *configdat* "setup" "use-wal") + (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) + (if (not file-exists) + (initproc db)) (if (not readyexists) (begin (common:simple-file-release-lock lockfname) (with-output-to-file readyfname @@ -3323,11 +3322,26 @@ db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) - + + + +(define (db:delete-steps-for-test! dbstruct run-id test-id) + ;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) ) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute + db + "UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps + test-id)))) + + ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) (db:with-db dbstruct run-id Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -1260,18 +1260,25 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== -(define (dcommon:populate-steps teststeps steps-matrix) - (let ((max-row 0) - (max-col 9) - (white "255 255 255") - (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED"))) - (failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL")))) +(define (dcommon:populate-steps teststeps steps-matrix run-id test-id) + (let* ((max-row 0) + (max-col 9) + (white "255 255 255") + + (testinfo (rmt:get-testinfo-state-status run-id test-id)) + (state (db:test-get-state testinfo)) + (status (db:test-get-status testinfo)) + (test-status-color (car (gutils:get-color-for-state-status state status))) + (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED"))) + (failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL")))) (if (null? teststeps) - (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") + (begin + (iup:attribute-set! steps-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")) (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) @@ -1278,13 +1285,15 @@ (let* ((status (vector-ref hed 3)) (val (vector-ref hed (- colnum 1))) (bgcolor (cond ((member (conc status) '("" "-" "#")) running-color) + ((member (conc status) '("0" 0)) white) - (else failcolor))) + (else test-status-color))) + ; (else failcolor))) (mtrx-rc (conc rownum ":" colnum))) ;;(print "BB> status=>"status"< bgcolor="bgcolor) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum 5) (iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor)) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -38,121 +38,128 @@ ;;(rmt:get-test-info-by-id run-id test-id) -> testdat (define (ezsteps:run-from testdat start-step-name run-one) - (let* ((test-run-dir ;; (filedb:get-path *fdb* + ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test + (let* ((do-update-test-state-status #f) + (test-run-dir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) + (rollup-status-string #f) + (rollup-status-sym #f) (exit-info (vector #t #t #t)) - (test-id (db:test-get-id testdat)) - (run-id (db:test-get-run_id testdat)) - (test-name (db:test-get-testname testdat)) + (test-id (db:test-get-id testdat)) + (run-id (db:test-get-run_id testdat)) + (test-name (db:test-get-testname testdat)) + (orig-test-state (db:test-get-state testdat)) + (orig-test-status (db:test-get-status testdat)) (kill-job #f)) ;; for future use (on re-factoring with launch.scm code + + ;; keep trying till NFS deigns to populate test run dir on this host (let loop ((count 5)) - (if (common:file-exists? test-run-dir) - (push-directory test-run-dir) + (if (not (common:file-exists? test-run-dir)) + ;;(push-directory test-run-dir) (if (> count 0) (begin (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") (sleep 3) (loop (- count 1)))))) + (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway - (if (not (> (length ezstepslst) 0)) + (if (not (> (length ezstepslst) 0)) (message-window "ERROR: You can only re-run steps defined via ezsteps") (begin (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) - (prevstep #f) - (runflag #f)) ;; flag used to skip steps when not starting at the beginning + (status-sym-so-far 'pass) + ;;(runflag #f) + (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning (if (vector-ref exit-info 1) - (let* ((stepname (car ezstep)) ;; do stuff to run the step - (stepinfo (cadr ezstep)) - (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) - (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each - (stepcmd (list-ref stepparts 3)) - (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!! - (logpro-used #f)) - - ;; Skip steps until hit start-step-name - ;; - (if (and start-step-name - (not runflag)) - (if (equal? stepname start-step-name) - (set! runflag #t) ;; and continue - (if (not (null? tal)) - (loop (car tal)(cdr tal) stepname #f)))) - - (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts - " stepparms: " stepparms " stepcmd: " stepcmd) - - (if (common:file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) - - ;; call the command using mt_ezstep - (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) - - (debug:print 4 *default-log-port* "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #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! run-mutex) - (vector-set! exit-info 0 pid) - (vector-set! exit-info 1 exit-status) - (vector-set! exit-info 2 exit-code) - (mutex-unlock! run-mutex) - (if (eq? pid-val 0) - (begin - (thread-sleep! 1) - (processloop (+ i 1)))) - )) - (let ((exinfo (vector-ref exit-info 2)) - (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) - (if logpro-used - (rmt:test-set-log! run-id 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))) - (overall-status (cond - ((eq? rollup-status 2) 'warn) - ((eq? rollup-status 0) 'pass) - (else 'fail))) - (next-status (cond - ((eq? overall-status 'pass) this-step-status) - ((eq? overall-status 'warn) - (if (eq? this-step-status 'fail) 'fail 'warn)) - (else 'fail)))) - (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used - " this-step-status: " this-step-status " overall-status: " overall-status - " 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 - (tests:test-set-status! run-id test-id "RUNNING" "WARN" - (if (eq? this-step-status 'warn) "Logpro warning found" #f) - #f)) - ((pass) - (tests:test-set-status! run-id test-id "RUNNING" "PASS" #f #f)) - (else ;; 'fail - (set! rollup-status 1) ;; force fail - (tests:test-set-status! run-id test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) - )))) - (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) - (not (null? tal))) - (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop - (loop (car tal) (cdr tal) stepname runflag)))) + (let* ((stepname (car ezstep)) ;; do stuff to run the step + (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro"))) + (stepinfo (cadr ezstep)) + (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) + (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each + (stepcmd (list-ref stepparts 3)) + (script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep + (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name))) + (proceed-with-this-step + (or (not start-step-name) + (equal? stepname start-step-name) + (and saw-start-step-name (not run-one)) + saw-start-step-name-next + (and start-step-name (equal? stepname start-step-name)))) + ) + (set! do-update-test-state-status (and proceed-with-this-step (null? tal))) + ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status) + (cond + ((and (not proceed-with-this-step) (null? tal)) + 'done) + ((not proceed-with-this-step) + (loop (car tal) + (cdr tal) + status-sym-so-far + saw-start-step-name-next)) + (else + (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + " stepparms: " stepparms " stepcmd: " stepcmd) + (debug:print 4 *default-log-port* "script: " script) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + + ;; now launch the script + (let ((pid (process-run script))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! run-mutex) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! run-mutex) + (if (eq? pid-val 0) + (begin + (thread-sleep! 1) + (processloop (+ i 1)))) + )) + (let ((exinfo (vector-ref exit-info 2)) + (logfna (if logpro-used (conc stepname ".html") ""))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) + + (if logpro-used + (rmt:test-set-log! run-id test-id (conc stepname ".html"))) + + ;; set the test final status + (let* ((this-step-status (cond + (logpro-used + (common:logpro-exit-code->status-sym (vector-ref exit-info 2))) + ((eq? (vector-ref exit-info 2) 0) + 'pass) + (else + 'fail))) + (overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far)) + (overall-status-string (status-sym->string overall-status-sym))) + (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + " this-step-status: " this-step-status " overall-status: " overall-status-sym) + ;;" next-status: " next-status " rollup-status: " rollup-status) + (set! rollup-status-string overall-status-string) + (set! rollup-status-sym overall-status-sym) + (tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f))) + + (if (and + (not run-one) + (common:steps-can-proceed-given-status-sym rollup-status-sym) + (not (null? tal))) + (loop (car tal) + (cdr tal) + rollup-status-sym + saw-start-step-name-next))))) (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) @@ -161,38 +168,30 @@ (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (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 ) - (new-status (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")))) ;; (db:test-get-status testinfo))) + (new-status rollup-status-string) + ) ;; (db:test-get-status testinfo))) (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (tests:test-set-status! run-id test-id - new-state - new-status + (if do-update-test-state-status new-state orig-test-state) + (if do-update-test-state-status new-status orig-test-status) (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest - (if (not (equal? item-path "")) + (if (and (not (equal? item-path "")) do-update-test-state-status) (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f)))) ;; 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 ))) - (pop-directory) - rollup-status)) + ;;(pop-directory) + rollup-status-string)) (define (ezsteps:spawn-run-from testdat start-step-name run-one) (thread-start! (make-thread (lambda () (ezsteps:run-from testdat start-step-name run-one)) (conc "ezstep run single step " start-step-name " run-one="run-one))) ) Index: junk/data.txt ================================================================== --- junk/data.txt +++ junk/data.txt @@ -1,27 +1,1 @@ 0 0 0 1 2 3 4 5 6 -0 0 1 1 2 3 4 5 6 -0 0 2 1 2 3 4 5 6 -0 1 0 1 2 3 4 5 6 -0 1 1 1 2 3 4 5 6 -0 1 2 1 2 3 4 5 6 -0 2 0 1 2 3 4 5 6 -0 2 1 1 2 3 4 5 6 -0 2 2 1 2 3 4 5 6 -1 0 0 1 2 3 4 5 6 -1 0 1 1 2 3 4 5 6 -1 0 2 1 2 3 4 5 6 -1 1 0 1 2 3 4 5 6 -1 1 1 1 2 3 4 5 6 -1 1 2 1 2 3 4 5 6 -1 2 0 1 2 3 4 5 6 -1 2 1 1 2 3 4 5 6 -1 2 2 1 2 3 4 5 6 -2 0 0 1 2 3 4 5 6 -2 0 1 1 2 3 4 5 6 -2 0 2 1 2 3 4 5 6 -2 1 0 1 2 3 4 5 6 -2 1 1 1 2 3 4 5 6 -2 1 2 1 2 3 4 5 6 -2 2 0 1 2 3 4 5 6 -2 2 1 1 2 3 4 5 6 -2 2 2 1 2 3 4 5 6 Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -85,11 +85,11 @@ ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) #f))) -(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) +(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) ;;; TODO: deprecate me in favor of ezsteps.scm (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) ;; (let ((info (cadr ezstep))) ;; (if (proc? info) "" info))) ;; (stepproc (let ((info (cadr ezstep))) @@ -645,11 +645,14 @@ (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) - + + ;; cleanup prior execution's steps + (rmt:delete-steps-for-test! run-id test-id) + (debug:print 2 *default-log-port* "Executing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup force-reread: #t)) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -18,6 +18,6 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6529) +(define megatest-version 1.6530) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1704,24 +1704,24 @@ ;; state: states status: statuses new-state-status: "NOT_STARTED,n/a"))) ;; RERUN ALL (if (args:get-arg "-rerun-all") ;; first set states/statuses correct - (begin + (let* ((rconfig (full-runconfigs-read))) (hash-table-set! args:arg-hash "-preclean" #t) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") state: #f ;; status: statuses new-state-status: "NOT_STARTED,n/a") (runs:clean-cache target runname *toppath*) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") ;; state: states status: #f new-state-status: "NOT_STARTED,n/a"))) (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -861,10 +861,14 @@ (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) + +(define (rmt:delete-steps-for-test! run-id test-id) + (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id))) + (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) (define (rmt:get-steps-info-by-id test-step-id) (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -593,11 +593,11 @@ finalres) ) ;; end lambda )) do-a-sync)) -(define (server:writable-watchdog dbstruct) +(define (server:writable-watchdog-bruteforce dbstruct) (thread-sleep! 1) ;; delay for startup (let* ((do-a-sync (server:get-bruteforce-syncer dbstruct)) (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t))) (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync (args:get-arg "-server")) @@ -611,6 +611,137 @@ (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))) +(define (server:writable-watchdog-deltasync dbstruct) + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (common:run-sync?)) + (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) + (debug-mode (debug:debug-mode 1)) + (last-time (current-seconds)) + (no-sync-db (db:open-no-sync-db)) + (sync-duration 0) ;; run time of the sync in milliseconds + ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) + ) + (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls + (debug:print-info 2 *default-log-port* "Periodic sync thread started.") + (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) + (if (and legacy-sync (not *time-to-exit*)) + (let* (;;(dbstruct (db:setup)) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + (mtpath (db:dbdat-get-path mtdb)) + (tmp-area (common:get-db-tmp-area)) + (start-file (conc tmp-area "/.start-sync")) + (end-file (conc tmp-area "/.end-sync"))) + (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") + (let loop () + ;; sync for filesystem local db writes + ;; + (mutex-lock! *db-multi-sync-mutex*) + (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write + (sync-in-progress *db-sync-in-progress*) + (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) + (should-sync (and (not *time-to-exit*) + (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed + (start-time (current-seconds)) + (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) + (mt-mod-time (file-modification-time mtpath)) + (last-sync-start (if (common:file-exists? start-file) + (file-modification-time start-file) + 0)) + (last-sync-end (if (common:file-exists? end-file) + (file-modification-time end-file) + 10)) + (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period + (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! + (< mt-mod-time last-sync-start))) + (sync-done (<= last-sync-start last-sync-end)) + (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) + (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting + (or need-sync should-sync) + (or sync-done sync-stale) + (not sync-in-progress) + (not recently-synced)))) + (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress + " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync + " sync-done=" sync-done " sync-period=" sync-period) + (if (and (> sync-period 5) + (common:low-noise-print 30 "sync-period")) + (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) + ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) + ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) + (if will-sync (set! *db-sync-in-progress* #t)) + (mutex-unlock! *db-multi-sync-mutex*) + (if will-sync + (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! + (sync-start (current-milliseconds))) + (with-output-to-file start-file (lambda ()(print (current-process-id)))) + + ;; put lock here + + ;; (if (or (not max-sync-duration) + ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally + (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive + (set! sync-duration (- (current-milliseconds) sync-start)) + (if (> res 0) ;; some records were transferred, keep the db alive + (begin + (mutex-lock! *heartbeat-mutex*) + (set! *db-last-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*) + (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) + (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))) +;; ;; TODO: factor this next routine out into a function +;; (with-input-from-pipe ;; this should not block other threads but need to verify this +;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*) +;; (lambda () +;; (let loop ((inl (read-line)) +;; (res #f)) +;; (if (eof-object? inl) +;; (begin +;; (set! sync-duration (- (current-milliseconds) sync-start)) +;; (cond +;; ((not res) +;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\"")) +;; ((> res 0) +;; (mutex-lock! *heartbeat-mutex*) +;; (set! *db-last-access* (current-seconds)) +;; (mutex-unlock! *heartbeat-mutex*)))) +;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl))) +;; (if matches +;; (string->number (cadr matches)) +;; #f)))) +;; (loop (read-line) +;; (or num-synced res)))))))))) + (if will-sync + (begin + (mutex-lock! *db-multi-sync-mutex*) + (set! *db-sync-in-progress* #f) + (set! *db-last-sync* start-time) + (with-output-to-file end-file (lambda ()(print (current-process-id)))) + + ;; release lock here + + (mutex-unlock! *db-multi-sync-mutex*))) + (if (and debug-mode + (> (- start-time last-time) 60)) + (begin + (set! last-time start-time) + (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + + (if (and (not *time-to-exit*) + (< count 6)) ;; was 11, changing to 4. + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (if (not *time-to-exit*) (loop)))) + ;; time to exit, close the no-sync db here + (db:no-sync-close-db no-sync-db) + (if (common:low-noise-print 30) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -15,21 +15,12 @@ # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see . -usage="mt_ezstep stepname prevstepname command [args ...]" - -if [[ "$MT_CMDINFO" == "" ]];then - if [[ -e megatest.sh ]];then - source megatest.sh - else - echo "ERROR: $0 should be run within a megatest test environment" - echo "Usage: $usage" - exit - fi -fi +usage="mt_ezstep stepname command [args ...]" + # Purpose: This is for the [ezsteps] secton in your testconfig file. # DO NOT USE IN YOUR SCRIPTS! # # Call like this: @@ -41,16 +32,15 @@ fi # Since the user may not have . on the path and since we are likely to want to # run test scripts in the current directory add the current dir to the path export PATH=$PATH:$PWD - +testrundir=$1; shift stepname=$1;shift -prevstepname=$1;shift + command=$* - allstatus=99 runstatus=99 logpropstatus=99 # prev_env=".ezsteps/${prevstepname}.sh" @@ -58,39 +48,36 @@ # if [[ -e "${prev_env}" ]];then # source $prev_env # fi # source the environment from the previous step if it exists +cd $testrundir +#if [[ "$MT_CMDINFO" == "" ]];then + if [[ -e megatest.sh ]];then + source megatest.sh + else + echo "ERROR: $0 should be run within a megatest test environment" + echo "Usage: $usage" + exit + fi +#fi + + # if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1 if [[ -e ${stepname}.logpro ]];then - # could do: - $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null - logprostatus=$? - # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log - # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) - allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) - runstatus=${allstatus[0]} - # logprostatus=${allstatus[1]} -else - $command &> ${stepname}.log - runstatus=$? - logprostatus=$runstatus -fi - -# If the test exits with non-zero, we will record FAIL even if logpro -# says it is a PASS - -if [[ $runstatus -ne 0 ]]; then - exitstatus=$runstatus -elif [[ $logprostatus -eq 0 ]]; then - exitstatus=$logprostatus -elif [[ $logprostatus -eq 2 ]]; then - exitstatus=2 -elif [[ $logprostatus -eq 1 ]]; then - exitstatus=1 -else - exitstatus=0 -fi - -# $MT_MEGATEST -env2file .ezsteps/${stepname} + eval $command 2>&1 ${stepname}.log + runstatus=$? + logpro ${stepname}.logpro ${stepname}.html &> /dev/null < ${stepname}.log + logprostatus=$? + + if [[ $runstatus == 0 ]]; then + exitstatus=$logprostatus + else + exitstatus=$runstatus + fi +else + eval $command &> ${stepname}.log + exitstatus=$? +fi + exit $exitstatus