Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -38,11 +38,12 @@ # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ - stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm tasksmod.scm + stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm tasksmod.scm \ + pkts.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template @@ -58,10 +59,11 @@ mofiles/processmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o mofiles/dbmod.o : mofiles/mtmod.o # mofiles/mtmod.o : mofiles/tcp-transportmod.o +mofiles/megatestmod.o : mofiles/pkts.o mofiles/dbfile.o : \ mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o mofiles/rmtmod.o : mofiles/tasksmod.o Index: megatestmod.scm ================================================================== --- megatestmod.scm +++ megatestmod.scm @@ -29,10 +29,13 @@ (declare (uses mtargs)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses configfmod)) +(declare (uses processmod)) +(declare (uses mtmod)) +(declare (uses pkts)) (use srfi-69) (module megatestmod * @@ -92,21 +95,34 @@ matchable md5 message-digest pathname-expand - regex + system-information + + ))) + +(import regex regex-case srfi-1 srfi-18 srfi-69 typed-records - system-information - + directory-utils + call-with-environment-variables + + commonmod + configfmod debugprint - ))) + dbmod + dbfile + processmod + mtmod + pkts + ) + ;;====================================================================== ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) @@ -794,123 +810,14 @@ (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) -;;;====================================================================== -;; S T A T E A N D S T A T U S F O R T E S T S -;;====================================================================== - -;; speed up for common cases with a little logic -(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) - (if (not (and run-id test-id)) - (begin - (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) - (print-call-chain (current-error-port)) - #f) - (begin - ;; cond - ;; ((and newstate newstatus newcomment) - ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) - ;; ((and newstate newstatus) - ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) - ;; (else - ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) - ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) - ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) - (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment) - ;; (mt:process-triggers run-id test-id newstate newstatus) - #t))) - -(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) - (let ((test-id (rmt:get-test-id run-id test-name item-path))) - (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) - -(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment) - (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id)) - (state (vector-ref test-vec 3))) - (if (equal? state "COMPLETED") - #t - (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)))) - - - -(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) - ;(let ((test-id (rmt:get-test-id run-id test-name item-path))) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) - ;; (mt:process-triggers run-id test-id new-state new-status) - #t);) - ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) - ;;====================================================================== ;; R U N S ;;====================================================================== -;; runs:get-runs-by-patt -;; get runs by list of criteria -;; register a test run with the db -;; -;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) -;; to extract info from the structure returned -;; -(define (mt:get-runs-by-patt keys runnamepatt targpatt) - (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) - (res '()) - (offset 0) - (limit 500)) - ;; (print "runsdat: " runsdat) - (let* ((header (vector-ref runsdat 0)) - (runslst (vector-ref runsdat 1)) - (full-list (append res runslst)) - (have-more (eq? (length runslst) limit))) - ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) - (if have-more - (let ((new-offset (+ offset limit)) - (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) - (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") - (debug:print-info 0 *default-log-port* "next-batch: " next-batch) - (loop next-batch - full-list - new-offset - limit)) - (vector header full-list))))) - -;;====================================================================== -;; T E S T S -;;====================================================================== - -(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) - (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) - (res '()) - (offset 0) - (limit 500)) - (let* ((full-list (append res testsdat)) - (have-more (eq? (length testsdat) limit))) - (if have-more - (let ((new-offset (+ offset limit))) - (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.") - (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) - full-list - new-offset - limit)) - full-list)))) - -(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) ) - (let* ((key (list run-id waitons ref-item-path mode)) - (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) - (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) - (if last-time - (< (current-seconds)(+ last-time 5)) - #f)))) - (if useres - (let ((result (vector-ref res 1))) - (debug:print 4 *default-log-port* "Using lazy value res: " result) - result) - (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) - (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) - newres)))) - ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) @@ -1016,8 +923,71 @@ (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) (if new-state-eh ;; moved from db:test-set-state-status (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh)) tr-res))))) + +(define (mt:process-triggers dbstruct run-id test-id newstate newstatus) + (if test-id + (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) + (if test-dat + (let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; ) + (test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (duration (db:test-get-run_duration test-dat)) + (comment (db:test-get-comment test-dat)) + (event-time (db:test-get-event_time test-dat)) + (tconfig #f) + (state (if newstate newstate (db:test-get-state test-dat))) + (status (if newstatus newstatus (db:test-get-status test-dat))) + (target (getenv "MT_TARGET")) + (runname (getenv "MT_RUNNAME"))) + ;; (mutex-lock! *triggers-mutex*) + ;;;;;; (handle-exceptions + ;;;;;; exn + ;;;;;; (begin + ;;;;;; (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus + ;;;;;; "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn + ;;;;;; "\n test-rundir="test-rundir + ;;;;;; "\n test-name="test-name + ;;;;;; "\n item-path="item-path + ;;;;;; "\n state="state + ;;;;;; "\n status="status + ;;;;;; "\n") + ;;;;;; (print-call-chain (current-error-port)) + ;;;;;; (with-output-to-port *default-log-port* + ;;;;;; (lambda () + ;;;;;; (print (condition->list exn)))) + ;;;;;; #f) + (if (and test-name + test-rundir) ;; #f means no dir set yet + ;; (common:file-exists? test-rundir) + ;; (directory? test-rundir)) + (call-with-environment-variables + (list (cons "MT_TEST_NAME" (or test-name "no such test")) + (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) + (cons "MT_ITEMPATH" (or item-path ""))) + (lambda () + (if (directory-exists? test-rundir) + (push-directory test-rundir) + (push-directory *toppath*)) + (set! tconfig (mt:lazy-read-test-config test-name)) + (for-each (lambda (trigger) + (let* ((munged-trigger (string-translate trigger "/ " "--")) + (logname (conc "last-trigger-" munged-trigger ".log"))) + ;; first any triggers from the testconfig + (let ((cmd (configf:lookup tconfig "triggers" trigger))) + (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status target runname))) + ;; next any triggers from megatest.config + (let ((cmd (configf:lookup *configdat* "triggers" trigger))) + (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status target runname))))) + (list + (conc state "/" status) + (conc state "/") + (conc "/" status))) + (pop-directory)) + )) ;; ) + ;; (mutex-unlock! *triggers-mutex*) + ))))) ) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -74,68 +74,5 @@ (begin (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) -(define (mt:process-triggers dbstruct run-id test-id newstate newstatus) - (if test-id - (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) - (if test-dat - (let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; ) - (test-name (db:test-get-testname test-dat)) - (item-path (db:test-get-item-path test-dat)) - (duration (db:test-get-run_duration test-dat)) - (comment (db:test-get-comment test-dat)) - (event-time (db:test-get-event_time test-dat)) - (tconfig #f) - (state (if newstate newstate (db:test-get-state test-dat))) - (status (if newstatus newstatus (db:test-get-status test-dat))) - (target (getenv "MT_TARGET")) - (runname (getenv "MT_RUNNAME"))) - ;; (mutex-lock! *triggers-mutex*) - ;;;;;; (handle-exceptions - ;;;;;; exn - ;;;;;; (begin - ;;;;;; (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus - ;;;;;; "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn - ;;;;;; "\n test-rundir="test-rundir - ;;;;;; "\n test-name="test-name - ;;;;;; "\n item-path="item-path - ;;;;;; "\n state="state - ;;;;;; "\n status="status - ;;;;;; "\n") - ;;;;;; (print-call-chain (current-error-port)) - ;;;;;; (with-output-to-port *default-log-port* - ;;;;;; (lambda () - ;;;;;; (print (condition->list exn)))) - ;;;;;; #f) - (if (and test-name - test-rundir) ;; #f means no dir set yet - ;; (common:file-exists? test-rundir) - ;; (directory? test-rundir)) - (call-with-environment-variables - (list (cons "MT_TEST_NAME" (or test-name "no such test")) - (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) - (cons "MT_ITEMPATH" (or item-path ""))) - (lambda () - (if (directory-exists? test-rundir) - (push-directory test-rundir) - (push-directory *toppath*)) - (set! tconfig (mt:lazy-read-test-config test-name)) - (for-each (lambda (trigger) - (let* ((munged-trigger (string-translate trigger "/ " "--")) - (logname (conc "last-trigger-" munged-trigger ".log"))) - ;; first any triggers from the testconfig - (let ((cmd (configf:lookup tconfig "triggers" trigger))) - (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status target runname))) - ;; next any triggers from megatest.config - (let ((cmd (configf:lookup *configdat* "triggers" trigger))) - (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status target runname))))) - (list - (conc state "/" status) - (conc state "/") - (conc "/" status))) - (pop-directory)) - )) ;; ) - ;; (mutex-unlock! *triggers-mutex*) - ))))) - Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1108,8 +1108,117 @@ ))) (if (common:api-changed?) (common:set-last-run-version))) +(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) ) + (let* ((key (list run-id waitons ref-item-path mode)) + (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) + (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (if last-time + (< (current-seconds)(+ last-time 5)) + #f)))) + (if useres + (let ((result (vector-ref res 1))) + (debug:print 4 *default-log-port* "Using lazy value res: " result) + result) + (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) + (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) + newres)))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) + (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) + (res '()) + (offset 0) + (limit 500)) + (let* ((full-list (append res testsdat)) + (have-more (eq? (length testsdat) limit))) + (if have-more + (let ((new-offset (+ offset limit))) + (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.") + (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) + full-list + new-offset + limit)) + full-list)))) + + +;; runs:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; to extract info from the structure returned +;; +(define (mt:get-runs-by-patt keys runnamepatt targpatt) + (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) + (res '()) + (offset 0) + (limit 500)) + ;; (print "runsdat: " runsdat) + (let* ((header (vector-ref runsdat 0)) + (runslst (vector-ref runsdat 1)) + (full-list (append res runslst)) + (have-more (eq? (length runslst) limit))) + ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) + (if have-more + (let ((new-offset (+ offset limit)) + (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) + (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") + (debug:print-info 0 *default-log-port* "next-batch: " next-batch) + (loop next-batch + full-list + new-offset + limit)) + (vector header full-list))))) + +;;;====================================================================== +;; S T A T E A N D S T A T U S F O R T E S T S +;;====================================================================== + +;; speed up for common cases with a little logic +(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (if (not (and run-id test-id)) + (begin + (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) + (print-call-chain (current-error-port)) + #f) + (begin + ;; cond + ;; ((and newstate newstatus newcomment) + ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) + ;; ((and newstate newstatus) + ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) + ;; (else + ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) + ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) + ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) + (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment) + ;; (mt:process-triggers run-id test-id newstate newstatus) + #t))) + +(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) + (let ((test-id (rmt:get-test-id run-id test-name item-path))) + (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) + +(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment) + (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id)) + (state (vector-ref test-vec 3))) + (if (equal? state "COMPLETED") + #t + (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)))) + + + +(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) + ;(let ((test-id (rmt:get-test-id run-id test-name item-path))) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) + ;; (mt:process-triggers run-id test-id new-state new-status) + #t);) + ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) ) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -165,5 +165,6 @@ (let ((newres (append (string-split hed " ") res))) (runconfig:expand-target newres)) (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated |# + Index: utils/plot-uses.scm ================================================================== --- utils/plot-uses.scm +++ utils/plot-uses.scm @@ -59,10 +59,18 @@ (print " \""unitname"\" -> \""modname"\";")) (print-err "ERROR: bad declare line \""inl"\"")) (loop modname)))) (else (loop modname))))))))) + +;; ./utils/plot-uses todot portlogger,stml2,debugprint,mtargs +;; apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm +;; mtmod.scm processmod.scm rmtmod.scm servermod.scm +;; tcp-transportmod.scm > uses.dot + +;; dot uses.dot -Tpdf -o uses.pdf + (define (main) (match (command-line-arguments) (("todot" ignoreunits . files) (let* ((ignores (string-split ignoreunits ",")))