Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -30,26 +30,31 @@ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm subrun.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files - -MSRCFILES = ftail.scm rmtmod.scm commonmod.scm ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm +# ftail.scm rmtmod.scm commonmod.scm removed +MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm # Eggs to install (straightforward ones) -EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ -dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ -json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ -spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 +EGGS=matchable readline aokpropos base64 regex-literals format \ +regex-case test coops trace csv dot-locking posix-utils posix-extras \ +directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 awful \ +http-client spiffy uri-common intarweb spiffy-request-vars \ +spiffy-directory-listing ssax sxml-serializer sxml-modifications iup \ +canvas-draw sqlite3 -GUISRCF = dashboard-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm +GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ +dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) +# compiled import files +MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) mofiles/%.o %.import.scm : %.scm @[ -e mofiles ] || mkdir -p mofiles csc $(CSCOPTS) -I $* -J -c $< -o mofiles/$*.o @touch $*.import.scm # ensure it is touched after the .o is made @@ -74,12 +79,14 @@ PNGFILES = $(shell cd docs/manual;ls *png) #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt -mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o - csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest +megatest.o : ducttape-lib.import.o + +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) ducttape-lib.import.o + csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest showmtesthash: @echo $(MTESTHASH) dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) @@ -174,16 +181,26 @@ vg.o dashboard.o : vg_records.scm dcommon.o : run_records.scm +mofiles/stml2.o : mofiles/cookie.o + +# special include based modules +mofiles/pkts.o : pkts/pkts.scm +# mofiles/mtargs.o : mtargs/mtargs.scm +# mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm +# mofiles/ulex.o : ulex/ulex.scm +mofiles/mutils.o : mutils/mutils.scm +mofiles/cookie.o : stml2/cookie.scm +mofiles/stml2.o : stml2/stml2.scm + # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm # for the modularized stuff -mofiles/rmtmod.o : mofiles/commonmod.o \ - mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o +rmt.o : mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o # *-inc.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi @@ -342,11 +359,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt ftail.import.scm readline-fix.scm serialize-env dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt readline-fix.scm serialize-env dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o commonmod.o cookie.o dashboard-main.o ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o tcmt.o rm -rf share #====================================================================== # Make the records files #====================================================================== Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -2684,11 +2684,11 @@ (start-time (current-milliseconds)) (tot-runs #f)) (if (eq? runnum 0)(dashboard:update-runs-data rdat)) (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat))) (let loop ((rn runnum)) - (if (and (< (- (current-milliseconds) start-time) 500) + (if (and (< (- (current-milliseconds) start-time) 250) (< rn tot-runs)) (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat))) 0 ;; start over (+ rn 1)))) ;; (+ runnum 1))) (dashboard:update-run-data rn rdat) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -20,22 +20,10 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) - readline apropos json http-client directory-utils typed-records - http-client srfi-18 extras format) - -;; Added for csv stuff - will be removed -;; -(use sparse-vectors) - -(import mutils ducttape-lib) - -;; (use zmq) - (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) @@ -44,10 +32,12 @@ (declare (uses tests)) (declare (uses genexample)) ;; (declare (uses daemon)) (declare (uses db)) ;; (declare (uses dcommon)) +(declare (uses stml2)) +(declare (uses pkts)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. @@ -54,17 +44,38 @@ (declare (uses env)) (declare (uses diff-report)) (declare (uses ftail)) (import ftail) +(import stml2) + +;; invoke the imports +;; (declare (uses mtargs.import)) +;; (declare (uses mtconfigf.import)) +(declare (uses cookie.import)) +(declare (uses stml2.import)) +(declare (uses pkts.import)) + (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) + readline apropos json http-client directory-utils typed-records + http-client srfi-18 extras format) + +;; Added for csv stuff - will be removed +;; +(use sparse-vectors) + +(import mutils ducttape-lib stml2) + +;; (use zmq) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -20,14 +20,10 @@ ;;====================================================================== ;; Tests ;;====================================================================== -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) -(import (prefix sqlite3 sqlite3:)) -(import stml2) - (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) @@ -34,10 +30,15 @@ ;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (declare (uses server)) +(declare (uses stml2)) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +(import (prefix sqlite3 sqlite3:)) +(import stml2) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -791,121 +792,121 @@ ;; tests:genrate dashboard body ;; (define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt) (let* ((start (* page pg-size)) - ;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) + ;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) (runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc")) - ; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update - (header (vector-ref runsdat 0)) - (runs (vector-ref runsdat 1)) + ; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update + (header (vector-ref runsdat 0)) + (runs (vector-ref runsdat 1)) (ctr 0) (test-runs-hash (tests:get-rest-data runs header numkeys)) (test-list (hash-table-keys test-runs-hash))) - - (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) - (s:title "Summary for " area-name) - (s:body 'onload "addEvents();" - (get-prev-links page linktree) - (get-next-links page linktree total-runs) - - (s:h1 "Summary for " area-name) - (s:h3 "Filter" ) - (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") - ;; top list - - (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 - (map (lambda (key) - (let* ((res (s:tr 'class "something" - (s:th key ) - (map (lambda (run) - (s:th (vector-ref run ctr))) - runs)))) - (set! ctr (+ ctr 1)) - res)) - keys) - (s:tr - (s:th "Run Name") - (map (lambda (run) - (s:th (db:get-value-by-header run header "runname"))) - runs)) - - (map (lambda (test-name) - (let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f)) - (item-keys (sort (hash-table-keys item-hash) string<=?))) - (map (lambda (item-name) + + (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (get-prev-links page linktree) + (get-next-links page linktree total-runs) + + (s:h1 "Summary for " area-name) + (s:h3 "Filter" ) + (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") + ;; top list + + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 + (map (lambda (key) + (let* ((res (s:tr 'class "something" + (s:th key ) + (map (lambda (run) + (s:th (vector-ref run ctr))) + runs)))) + (set! ctr (+ ctr 1)) + res)) + keys) + (s:tr + (s:th "Run Name") + (map (lambda (run) + (s:th (db:get-value-by-header run header "runname"))) + runs)) + + (map (lambda (test-name) + (let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f)) + (item-keys (sort (hash-table-keys item-hash) string<=?))) + (map (lambda (item-name) (let* ((res (s:tr 'class item-name - (s:td item-name 'class "test" ) - (map (lambda (run) - (let* ((run-test (hash-table-ref/default item-hash item-name #f)) - (run-id (db:get-value-by-header run header "id")) - (result (hash-table-ref/default run-test run-id "n/a")) - ;(relative-path (get-relative-path)) - (status (if (string? result) - result - (car result))) - (link (if (string? result) - result - (if (equal? flag #t) - (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) - (s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-")))))) - (s:td link 'class status))) - runs)))) - res)) - item-keys))) - test-list)))))) + (s:td item-name 'class "test" ) + (map (lambda (run) + (let* ((run-test (hash-table-ref/default item-hash item-name #f)) + (run-id (db:get-value-by-header run header "id")) + (result (hash-table-ref/default run-test run-id "n/a")) + ;(relative-path (get-relative-path)) + (status (if (string? result) + result + (car result))) + (link (if (string? result) + result + (if (equal? flag #t) + (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) + (s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-")))))) + (s:td link 'class status))) + runs)))) + res)) + item-keys))) + test-list)))))) ;; (tests:create-html-tree "test-index.html") ;; (define (tests:create-html-tree outf) - (let* ((lockfile (conc outf ".lock")) - (runs-to-process '()) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '()) (linktree (common:get-linktree)) (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) - (numkeys (length keys)) + (keys (rmt:get-keys)) + (numkeys (length keys)) (run-patt (or (args:get-arg "-run-patt") - (args:get-arg "-runname") - "%")) + (args:get-arg "-runname") + "%")) (target (or (args:get-arg "-target-patt") - (args:get-arg "-target") + (args:get-arg "-target") "%")) (targlist (string-split target "/")) (numtarg (length targlist)) (targtweaked (if (> numkeys numtarg) - (append targlist (make-list (- numkeys numtarg) "%")) - targlist)) + (append targlist (make-list (- numkeys numtarg) "%")) + targlist)) (target-patt (string-join targtweaked "/")) - ;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target - (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) + ;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target + (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) (pg-size 10)) (if (common:simple-file-lock lockfile) (begin - ;(print total-runs) - (let loop ((page 0)) - (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) - (get-prev-links (lambda (page linktree ) - (let* ((link (if (not (eq? page 0)) - (s:a "<<prev" 'href (conc "page" (- page 1) ".html")) - (s:a "" 'href (conc "page" page ".html"))))) - link))) - (get-next-links (lambda (page linktree total-runs) - (let* ((link (if (> total-runs (+ 10 (* page pg-size))) - (s:a "next>>" 'href (conc "page" (+ page 1) ".html")) - (s:a "" 'href (conc "page" page ".html"))))) - link))) ) - (print "total runs: " total-runs) - (s:output-new - oup - (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function - (close-output-port oup) - ; (set! page (+ 1 page)) - (if (> total-runs (* (+ 1 page) pg-size)) - (loop (+ 1 page))))) + ;(print total-runs) + (let loop ((page 0)) + (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) + (get-prev-links (lambda (page linktree ) + (let* ((link (if (not (eq? page 0)) + (s:a "<<prev" 'href (conc "page" (- page 1) ".html")) + (s:a "" 'href (conc "page" page ".html"))))) + link))) + (get-next-links (lambda (page linktree total-runs) + (let* ((link (if (> total-runs (+ 10 (* page pg-size))) + (s:a "next>>" 'href (conc "page" (+ page 1) ".html")) + (s:a "" 'href (conc "page" page ".html"))))) + link))) ) + (print "total runs: " total-runs) + (s:output-new + oup + (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function + (close-output-port oup) + ; (set! page (+ 1 page)) + (if (> total-runs (* (+ 1 page) pg-size)) + (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) - - #f))) + (begin + (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) (define (tests:readlines filename) (call-with-input-file filename (lambda (p)