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)