ADDED DONE
Index: DONE
==================================================================
--- /dev/null
+++ DONE
@@ -0,0 +1,36 @@
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# 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 .
+
+NOTE: This file gets copied occasionally into the wiki as "Roadmap DONE".
+ Do not make changes in the wiki, they will be lost!
+
+DONE
+====
+
+WW14
+. Streamline compilation - DONE, all non-official egg modules are now bundled.
+
+WW15
+. syscheck; touch file in home, tmp, runs, links and start xterm [DONE]
+
+WW16
+. archiving improvements/extentions [DONE]
+.. -get-data, -put-data [DONE]
+.. use MT_ vars if defined and no switch present [DONE]
+.. fix archive "first run" bug [DONE]
+.. areas path1 path2 ... -> search path for archives [NOT NEEDED - use -start-dir]
+.. -propagate -> move archive data forward when it is found in older bundles [NOT NEEDED - simply repost the data]
Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -19,40 +19,42 @@
# rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
-SRCFILES = common.scm items.scm launch.scm \
- ods.scm runconfig.scm server.scm configf.scm \
- db.scm keys.scm margs.scm megatest-version.scm \
- process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm filedb.scm tdb.scm \
- client.scm mt.scm \
- 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
+SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
+ server.scm configf.scm db.scm keys.scm margs.scm \
+ megatest-version.scm process.scm runs.scm tasks.scm \
+ tests.scm genexample.scm http-transport.scm filedb.scm \
+ tdb.scm client.scm mt.scm 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
-
-
-# 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
-
-GUISRCF = dashboard-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm
+# ftail.scm rmtmod.scm commonmod.scm removed
+MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
+ mtargs.scm commonmod.scm dbmod.scm adjutant.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 : %.scm
- mkdir -p mofiles
- csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+%.import.o : %.import.scm
+ csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.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
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
@@ -59,38 +61,32 @@
ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif
-CSIPATH=$(shell which csi)
-CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
-# ARCHSTR=$(shell uname -m)_$(shell uname -r)
-# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
-# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
-# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")
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
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES)
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
- csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES)
+ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
+include makefile.inc
TCMTOBJS = \
api.o \
archive.o \
cgisetup/models/pgdb.o \
@@ -110,23 +106,23 @@
ods.o \
portlogger.o \
process.o \
rmt.o \
mofiles/rmtmod.o \
- mofiles/commonmod.o \
rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
tests.o \
- subrun.o \
+ subrun.o
+# mofiles/commonmod.o \
tcmt : $(TCMTOBJS) tcmt.scm
- csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt
+ csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
@@ -141,101 +137,128 @@
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
-#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
-# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard
-
-#
-# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
-# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
-
# Special dependencies for the includes
-tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \
-archive.o megatest.o : db_records.scm
+common.o : mofiles/commonmod.o
+
+tests.o db.o launch.o runs.o dashboard-tests.o \
+dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \
+monitor.o dashboard.o archive.o megatest.o : db_records.scm
+
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
+
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
+
tests.o tasks.o dashboard-tasks.o : task_records.scm
+
runs.o : test_records.scm
+
megatest.o : megatest-fossil-hash.scm
+
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
+
common_records.scm : altdb.scm
+
+mofiles/stml2.o : mofiles/cookie.o
+configf.o : mofiles/commonmod.o
+
vg.o dashboard.o : vg_records.scm
+
dcommon.o : run_records.scm
-# Temporary while transitioning to new routine
-# runs.o : run-tests-queue-classic.scm run-tests-queue-new.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
# for the modularized stuff
-mofiles/rmtmod.o : mofiles/commonmod.o
+rmt.o : mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o mofiles/mtargs.o
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
$(OFILES) $(GOFILES) : common_records.scm
-%.o : %.scm $(MOFILES)
- csc $(CSCOPTS) -c $< $(MOFILES)
+# This having the full list of MOFILES cause everything to be rebuilt every time.
+#
+# %.o : %.scm $(MOFILES)
+# csc $(CSCOPTS) -c $< $(MOFILES)
+#
+%.o : %.scm
+ csc $(CSCOPTS) -c $<
-$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
+# specific rules for .o files that genuninely depend on mofiles/something
+#
+megatest.o : megatest.scm stml2.o mutils.o commonmod.o
+ csc $(CSCOPTS) -c megatest.scm stml2.o mutils.o commonmod.o
+
+dashboard.o : dashboard.scm stml2.o mutils.o commonmod.o dbmod.o
+ csc $(CSCOPTS) -c megatest.scm stml2.o mutils.o commonmod.o dbmod.o
+
+common.o : megatest.scm mofiles/commonmod.o common.scm
+ csc $(CSCOPTS) -c common.scm mofiles/commonmod.o
+
+configf.o : configf.scm mofiles/commonmod.o
+ csc $(CSCOPTS) -c configf.scm mofiles/commonmod.o
+
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtest : mtest
@echo Installing to PREFIX=$(PREFIX)
- $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
+ $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest
+
+$(PREFIX)/bin/megatest : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
chmod a+x $(PREFIX)/bin/megatest
-$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
- $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
+$(PREFIX)/bin/.$(ARCHSTR)/bin/ndboard : ndboard
+ $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/bin/ndboard
$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
chmod a+x $(PREFIX)/bin/newdashboard
# mtutil
-$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
- $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtut : mtut
+ $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut
install-mtut : mtut
$(INSTALL) mtut $(PREFIX)/bin/mtut
-$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper
+$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil
chmod a+x $(PREFIX)/bin/mtutil
# mtexec
mtexec: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtexec.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtexec.scm -o mtexec
-$(PREFIX)/bin/.$(ARCHSTR)/mtexec : mtexec
- $(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/mtexec
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec : mtexec
+ $(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec
-$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper
+$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec
chmod a+x $(PREFIX)/bin/mtexec
# tcmt
-$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
- $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt
+$(PREFIX)/bin/.$(ARCHSTR)/bin/tcmt : tcmt
+ $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/bin/tcmt
-$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
+$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/bin/tcmt utils/mk_wrapper
utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
chmod a+x $(PREFIX)/bin/tcmt
-# $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
-# $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard
-
-# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper
-# utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
-# chmod a+x $(PREFIX)/bin/mdboard
-
-# $(HELPERS) : utils/%
-# $(INSTALL) $< $@
-# chmod a+x $@
-
$(PREFIX)/bin/mt_laststep : utils/mt_laststep
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/mt_runstep : utils/mt_runstep
@@ -268,18 +291,14 @@
$(PREFIX)/bin/nbfind : utils/nbfind
$(INSTALL) $< $@
chmod a+x $@
-$(PREFIX)/bin/loadrunner : utils/loadrunner
+$(PREFIX)/bin/mtrunner : utils/mtrunner
$(INSTALL) $< $@
chmod a+x $@
-# $(PREFIX)/bin/refdb : refdb
-# $(INSTALL) $< $@
-# chmod a+x $@
-
deploytarg/nbfake : utils/nbfake
$(INSTALL) $< $@
chmod a+x $@
deploytarg/viewscreen : utils/viewscreen
@@ -294,29 +313,29 @@
make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR)
mtest-reaper: $(PREFIX)/bin/mtest-reaper
# install dashboard as dboard so wrapper script can be called dashboard
-$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
+$(PREFIX)/bin/.$(ARCHSTR)/bin/dboard : dboard $(FILES)
+ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/bin/dboard
+
+$(PREFIX)/bin/dashboard : $(PREFIX)/bin/.$(ARCHSTR)/bin/dboard utils/mk_wrapper
utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
- $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
-install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
- $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
- $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
- $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
+install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest $(PREFIX)/bin/megatest \
+ $(PREFIX)/bin/.$(ARCHSTR)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
+ $(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
+ $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
$(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js
-# $(PREFIX)/bin/.$(ARCHSTR)/ndboard
-
-# $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
+ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/bin
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
test: tests/tests.scm
cd tests;csi -I .. -b -n tests.scm
@@ -326,56 +345,49 @@
$(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 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
-#======================================================================
-
-# vg_records.scm : records.sh
-# ./records.sh
-
#======================================================================
# Deploy section (not complete yet)
#======================================================================
+
+# Eggs to install (straightforward ones)
+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
$(DEPLOYHELPERS) : utils/mt_*
$(INSTALL) $< $@
chmod a+X $@
deploytarg/apropos.so : Makefile
chicken-install -p deploytarg -deploy -keep-installed $(EGGS)
-# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
-# chicken-install -prefix deploytarg -deploy $$i;done
-
-# deploytarg/libsqlite3.so :
-# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3
-
deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so
-# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so
-# for i in iup im cd av call sqlite; do \
-# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \
-# done
-# cp $(CKPATH)/include/*.h deploytarg
-
# puts deployed megatest in directory "megatest"
deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so
csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
mv deploytarg/deploytarg deploytarg/mtest
deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
mv deploytarg/deploytarg deploytarg/dboard
-# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
-# megatest-version.o tdb.o ods.o mt.o keys.o
datashare-testing/sd : datashare.scm $(OFILES)
csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd
datashare-testing/sdat: sharedat.scm $(OFILES)
csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat
@@ -402,17 +414,10 @@
rm datashare-testing/sretrieve
rm datashare-testing/spublish
sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish
-
-# base64 dot-locking \
-# csv-xml z3
-
-# "(define (toplevel-command . a) #f)"
-# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \
-
readline-fix.scm :
if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
echo "(define *use-new-readline* #f)" > readline-fix.scm; \
else \
echo "(define *use-new-readline* #t)" > readline-fix.scm;\
@@ -426,28 +431,75 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
-
-# create a pdf dot graphviz diagram from notations in rmt.scm
-rmt.pdf : rmt.scm
- grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
-
buildmanual:
cd docs/manual && make
-wikipage=plan
-editwiki:
- cd docs/manual && ../../utils/editwiki $(wikipage)
-
viewmanual:
arora docs/manual/megatest_manual.html
targets:
@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'
unit :
cd tests;make unit
+
+#======================================================================
+# Attic
+#======================================================================
+
+# portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+# csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+
+# create a pdf dot graphviz diagram from notations in rmt.scm
+# rmt.pdf : rmt.scm
+# grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
+
+# wikipage=plan
+# editwiki:
+# cd docs/manual && ../../utils/editwiki $(wikipage)
+
+# base64 dot-locking \
+# csv-xml z3
+
+# "(define (toplevel-command . a) #f)"
+# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \
+
+# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
+# megatest-version.o tdb.o ods.o mt.o keys.o
+
+# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so
+# for i in iup im cd av call sqlite; do \
+# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \
+# done
+# cp $(CKPATH)/include/*.h deploytarg
+
+# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
+# chicken-install -prefix deploytarg -deploy $$i;done
+
+# deploytarg/libsqlite3.so :
+# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3
+
+#======================================================================
+# Make the records files
+#======================================================================
+
+# vg_records.scm : records.sh
+# ./records.sh
+
+# $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
+# $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard
+
+# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper
+# utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
+# chmod a+x $(PREFIX)/bin/mdboard
+
+# $(HELPERS) : utils/%
+# $(INSTALL) $< $@
+# chmod a+x $@
+
+# ARCHSTR=$(shell uname -m)_$(shell uname -r)
+# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
+# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
Index: NOTES
==================================================================
--- NOTES
+++ NOTES
@@ -158,5 +158,9 @@
INFO: (0) Server shutdown complete. Exiting
Start: 0 at Sun Apr 28 22:18:25 MST 2013
Max: 52 at Sun Apr 28 23:06:59 MST 2013
End: 6 at Sun Apr 28 23:47:51 MST 2013
+
+========================================================================
+
+
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -13,22 +13,100 @@
# 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 .
+NOTE: This file gets copied occasionally into the wiki as "Roadmap".
+ Do not make changes in the wiki, they will be lost!
+
+See the file "DONE" to see completed items.
+FIXME
+====
+
+.dump
+----------------
+WARNING: disk disk0 at path "/mfs/tmp/archive" is not a directory - ignoring it.
+
+Warning (#): in thread: unbound variable: block-id
+
+ Call history:
+
+ common.scm:693: hash-table-ref/default
+ common.scm:694: current-seconds
+ common.scm:697: hash-table-set!
+ common.scm:2232: debug:print
+ common_records.scm:140: debug:debug-mode
+ common_records.scm:141: with-output-to-port
+ common.scm:2245: directory?
+ common.scm:2246: common:low-noise-print
+ common.scm:692: g2022
+ common.scm:692: g2022
+ common.scm:692: string-intersperse
+ common.scm:693: hash-table-ref/default
+ common.scm:694: current-seconds
+ common.scm:2261: debug:print
+ common_records.scm:140: debug:debug-mode
+ archive.scm:125: debug:print <--
+INFO: (0) Estimating disk space usage for scriptinc/: 184
+
+Error: uncaught exception: #
+
+ Call history:
+
+ common.scm:1299: ##sys#get-keyword
+ common.scm:1299: call-with-current-continuation
+ common.scm:1299: with-exception-handler
+ common.scm:1299: ##sys#call-with-values
+ common.scm:1304: thunk
+ common.scm:1310: file-exists?
+ common.scm:1299: k2554
+ common.scm:1299: g2558
+ runs.scm:2438: common:get-disk-space-used
+ common.scm:2128: conc
+ common.scm:2128: with-input-from-pipe
+ runs.scm:2438: debug:print-info
+ common_records.scm:235: debug:debug-mode
+ common_records.scm:236: port?
+ common_records.scm:236: with-output-to-port
+ runs.scm:2443: thread-join! <--
+Press any key to continue
+----------------
+
TODO
====
-. Dashboard should resist running from non-homehost
+WW15
+. fill newview matrix with data, filter pipeline gui elements
+. improve [script], especially indent handling
+
+WW16
+. split db into megatest.db (runs etc.) db/.db
+. release basic newview implementation
+
+WW18
+. release split db implementation
+. mtutil calls from dashboard (for remote control)
+. logs browser (esp. for surfacing mtutil related activities)
+
+WW19
+. break command line into sections; all, run control, queries, utilities etc.
+. pull in ftfplan (not integrated, just code pulled in)
+
+WW20
+. ./configure => ubuntu, sles11, sles12, rh7
+. Jenkins junit XML support
+. Add output flushing in teamcity support
+. Switch to using simple runs query everywhere
+. Add end_time to runs and add a rollup call that sets state, status and end_time
-
+Future
+. Switch to scsh-process pipeline management for job execution/control
+. Use call-with-environment-variables more.
Migration to inmem db plus per run db
-------------------------------------
. Re-work the dbstruct data structure?
.. Move main.db to global?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
-. Re-work all queries to use run-id to dereference server
. Open main.db directly in calls to -runtests etc. No need to talk remote?
-. remove common:faux-lock
ADDED adjutant.scm
Index: adjutant.scm
==================================================================
--- /dev/null
+++ adjutant.scm
@@ -0,0 +1,34 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; 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 .
+
+;;======================================================================
+
+(declare (unit adjutant))
+
+(module adjutant
+ *
+
+(import scheme chicken data-structures extras files)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
+ md5 message-digest
+ regex srfi-1)
+
+(define (adjutant-run)
+ (print "Running the adjutant!"))
+
+)
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -58,10 +58,11 @@
get-target
;; register-run
get-tests-tags
get-test-times
get-tests-for-run
+ get-tests-for-run-state-status
get-test-id
get-tests-for-runs-mindata
get-tests-for-run-mindata
get-run-name-from-id
get-runs
@@ -292,10 +293,11 @@
((get-run-status) (apply db:get-run-status dbstruct params))
((get-run-state) (apply db:get-run-state dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((set-run-state-status) (apply db:set-run-state-status dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
+ ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((simple-get-runs) (apply db:simple-get-runs dbstruct params))
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -90,11 +90,11 @@
(pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
(apath (if pscript
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: script \"" pscript-cmd "\" failed to run properly.")
+ (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly.")
(exit 1))
(with-input-from-pipe
pscript-cmd
read-line))
#f)) ;; this is the user-calculated archive path
@@ -116,13 +116,16 @@
;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
(if block-id ;; (and block-id allocation-id)
(let ((res (cons block-id archive-path)))
(hash-table-set! blockid-cache key res)
res)
- #f))
- #f)) ;; no best disk found
- )))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path)
+ #f)))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", block-id=" block-id)
+ #f)))))) ;; no best disk found
;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
@@ -182,13 +185,11 @@
partial-path-index)
#f))
;; we need our archive dir checked for every test to enable folks who want to store other ways.
(archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
(archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1))
-
- )
+ (archive-id (if archive-info (car archive-info) -1)))
(if (not archive-dir) ;; no archive disk found, this is fatal
(begin
(debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
min-space " MB space to the [archive-disks] section of megatest.config")
@@ -246,11 +247,20 @@
(arch-group (hash-table-ref arch-groups test-base))
(arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
(archive-id (car arch-info))
(archive-dir (cdr arch-info)))
(debug:print 0 *default-log-port* "Processing disk-group " test-base)
- (let* ((test-paths (hash-table-ref disk-groups test-base)))
+ (let* ((test-paths-in (hash-table-ref disk-groups test-base))
+ (test-paths (if (args:get-arg "-include")
+ (let ((subpaths (string-split (args:get-arg "-include") ",")))
+ (apply append
+ (map (lambda (p)
+ (map (lambda (subp)
+ (conc p "/" subp))
+ subpaths))
+ test-paths-in)))
+ test-paths-in)))
(if (not (common:file-exists? archive-dir))
(create-directory archive-dir #t))
(case archiver
((bup) ;; Archive using bup
(let* ((bup-init-params (list "-d" archive-dir "init"))
@@ -300,12 +310,14 @@
(for-each
(lambda (test-dat)
(let ((test-id (db:test-get-id test-dat))
(run-id (db:test-get-run_id test-dat)))
(rmt:test-set-archive-block-id run-id test-id archive-id)
- (if (member archive-command '("save-remove"))
- (runs:remove-test-directory test-dat 'archive-remove))))
+ (if (member (symbol->string archive-command) '("save-remove"))
+ (begin
+ (debug:print-info 0 *default-log-port* "remove testdat")
+ (runs:remove-test-directory test-dat 'archive-remove)))))
(hash-table-ref test-groups test-base)))))
(hash-table-keys disk-groups))
#t))
(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can
@@ -343,11 +355,14 @@
(archive-block-id (db:test-get-archived test-dat))
(archive-block-info (rmt:test-get-archive-block-info archive-block-id))
(archive-path (if (vector? archive-block-info)
(vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
#f)) ;; no archive found?
- (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))
+ (include-paths (args:get-arg "-include"))
+ (exclude-pattern (args:get-arg "-exclude-rx"))
+ (exclude-file (args:get-arg "-exclude-rx-from")))
;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
;;
(if (and (not toplevel/children) ;; special handling needed for toplevel with children
prev-test-physical-path
@@ -386,6 +401,90 @@
(run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
;; (mutex-unlock! bup-mutex)
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
(debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
(filter vector? tests))))
-
+
+(define (common:get-youngest-test tests)
+ (if (null? tests)
+ #f
+ (let ((res #f))
+ (for-each
+ (lambda (test-dat)
+ (let ((event-time (db:test-get-event_time test-dat)))
+ (if (or (not res)
+ (> event-time (db:test-get-event_time res)))
+ (set! res test-dat))))
+ tests)
+ res)))
+
+;; from an archive get a specific path - works ONLY with bup for now
+;;
+(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex)
+ (if (null? tests)
+ (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
+
+ (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ ;; (test-dat (common:get-youngest-test tests))
+ (destpath (args:get-arg "-dest")))
+ (cond
+ ((null? tests)
+ (debug:print-error 0 *default-log-port*
+ "No test matching provided target, runname pattern and test pattern found."))
+ ((file-exists? destpath)
+ (debug:print-error 0 *default-log-port*
+ "Destination path alread exists! Please remove it before running get."))
+ (else
+ (let loop ((rem-tests tests))
+ (let* ((test-dat (common:get-youngest-test rem-tests))
+ (item-path (db:test-get-item-path test-dat))
+ (test-name (db:test-get-testname test-dat))
+ (test-id (db:test-get-id test-dat))
+ (run-id (db:test-get-run_id test-dat))
+ (run-name (rmt:get-run-name-from-id run-id))
+ (keyvals (rmt:get-key-val-pairs run-id))
+ (target (string-intersperse (map cadr keyvals) "/"))
+
+ (toplevel/children (and (db:test-get-is-toplevel test-dat)
+ (> (rmt:test-toplevel-num-items run-id test-name) 0)))
+ (test-partial-path (conc target "/" run-name "/"
+ (db:test-make-full-name test-name item-path)))
+ ;; note the trailing slash to get the dir inspite of it being a link
+ (test-path (conc linktree "/" test-partial-path))
+ (archive-block-id (db:test-get-archived test-dat))
+ (archive-block-info (rmt:test-get-archive-block-info archive-block-id))
+ (archive-path (if (vector? archive-block-info)
+ (vector-ref archive-block-info 2)
+ #f))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id
+ "/latest/" test-partial-path))
+ (include-paths (args:get-arg "-include"))
+ (exclude-pattern (args:get-arg "-exclude-rx"))
+ (exclude-file (args:get-arg "-exclude-rx-from")))
+
+ (if (and archive-path ;; no point in proceeding if there is no actual archive
+ (not toplevel/children))
+ (begin
+ (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
+ ;; " " ;; What is the empty string for?
+ (if include-paths
+ (map (lambda (p)
+ (conc archive-internal-path "/" p))
+ (string-split include-paths ","))
+ (list archive-internal-path)))))
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
+ " from archive in " archive-path " ... " archive-internal-path)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
+ (let ((new-rem-tests (filter (lambda (tdat)
+ (or (not (eq? (db:test-get-id tdat) test-id))
+ (not (eq? (db:test-get-run_id tdat) run-id))))
+ rem-tests) ))
+ (debug:print-info 0 *default-log-port*
+ "No archive path in the record for run-id=" run-id
+ " test-id=" test-id ", skipping.")
+ (if (null? new-rem-tests)
+ (begin
+ (debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...")
+ #f)
+ (loop new-rem-tests)))))))))))
+
ADDED autostuff/.mtutil.scm
Index: autostuff/.mtutil.scm
==================================================================
--- /dev/null
+++ autostuff/.mtutil.scm
@@ -0,0 +1,88 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; 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 .
+
+(use json)
+(use ducttape-lib)
+
+(define (get-last-runname area-path target)
+ (let* ((run-data (with-input-from-pipe (conc "megatest -list-runs % -target " target " -fields runs:runname,event_time -dumpmode sexpr -start-dir " area-path)
+ read)))
+ (if (or (not run-data)
+ (null? run-data))
+ #f
+ (let* ((name-time (let ((dat (map cdadr (alist-ref target run-data equal?)))) ;; (("runname" . "2017w07.0-0047") ("event_time" . "1487490424"))
+ ;; (print "dat=" dat)
+ (map (lambda (item)
+ (cons (alist-ref "runname" item equal?)
+ (string->number (alist-ref "event_time" item equal?))))
+ dat)))
+ (sorted (sort name-time (lambda (a b)(> (cdr a)(cdr b)))))
+ (last-name (if (null? sorted)
+ #f
+ (caar sorted))))
+ last-name))))
+
+(define (str-first-char->number str)
+ (char->integer (string-ref str 0)))
+
+;; example of how to set up and write target mappers
+;; NOTE: maps a *list* of targets!
+;;
+;; (? target run-name area area-path reason contour mode-patt)
+;;
+(add-target-mapper 'prefix-contour
+ (lambda (runkey area contour)
+ (print "target: " runkey)
+ (list (conc contour "/" runkey))))
+#;(add-target-mapper 'prefix-area-contour
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (conc area "/" contour "/" target)))
+
+(add-runname-mapper 'corporate-ww
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
+ (let* ((last-name (get-last-runname area-path target))
+ (last-letter (let* ((ch (if (string? last-name)
+ (let ((len (string-length last-name)))
+ (substring last-name (- len 1) len))
+ "a"))
+ (chnum (str-first-char->number ch))
+ (a (str-first-char->number "a"))
+ (z (str-first-char->number "z")))
+ (if (and (>= chnum a)(<= chnum z))
+ chnum
+ #f)))
+ (next-letter (if last-letter
+ (list->string
+ (list
+ (integer->char
+ (+ last-letter 1)))) ;; surely there is an easier way?
+ "a")))
+ ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
+ (conc (seconds->wwdate (current-seconds)) next-letter))))
+
+(add-runname-mapper 'auto
+ (lambda (target run-name area area-path reason contour mode-patt)
+ "auto-eh"))
+
+;; run only areas where first letter of area name is "a"
+;;
+(add-area-checker 'first-letter-a
+ (lambda (area target contour)
+ (string-match "^a.*$" area)))
+
+
ADDED autostuff/megatest.config
Index: autostuff/megatest.config
==================================================================
--- /dev/null
+++ autostuff/megatest.config
@@ -0,0 +1,85 @@
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# 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 .
+
+## commented out due to a bug in v1.6501 in mtutil
+[fields]
+a text
+b text
+c text
+
+[default]
+# usercode .mtutil.scm
+# areafilter area-to-run
+# targtrans generic-target-translator
+# runtrans generic-runname-translator
+usercode .mtutil.scm
+# areafilter area-to-run
+targtrans prefix-contour-broken
+# runtrans generic-runname-translator
+
+[setup]
+pktsdirs /mfs/home/matt/orion_automation/pkts
+
+[areas]
+
+# path-to-area map-target-script(future, optional)
+# someqa path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
+# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
+# the target translator can return: a/target OR (list/of targets/to apply/run)
+# OR #f i.e. run nothing
+
+# ext-tests path=ext-tests; targtrans=prefix-contour;
+
+
+ext path=/mfs/home/matt/automation_areas/megatest/ext-tests; targtrans=prefix-contour
+
+[contours]
+# selector=tag-expr/mode-patt
+quick areas=ext; selector=/QUICKPATT
+# quick2 areafn=check-area; selector=/QUICKPATT
+full areas=ext
+# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
+# full areas=fullrun,ext-tests; selector=MAXPATT/
+# short areas=fullrun,ext-tests; selector=MAXPATT/
+# all areas=fullrun,ext-tests
+# snazy selector=QUICKPATT/
+
+[nopurpose]
+
+[access]
+ext matt:admin mattw:owner
+
+[accesstypes]
+admin run rerun resume remove set-ss rerun-clean
+owner run rerun resume remove rerun-all
+badguy set-ss
+
+[setup]
+maxload 1.2
+
+[listeners]
+localhost:12345 contact=matt@kiatoa.com
+localhost:54321 contact=matt@kiatoa.com
+
+[listener]
+script nbfake echo
+
+
+[server]
+timeout 1
+
+[include local.config]
ADDED autostuff/runconfigs.config
Index: autostuff/runconfigs.config
==================================================================
--- /dev/null
+++ autostuff/runconfigs.config
@@ -0,0 +1,112 @@
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# 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 .
+
+# To get emacs font highlighing in the various megatest configs do this:
+#
+# Install emacs-goodies-el:
+# sudo apt install emacs-goodies-el
+# Add to your ~/.emacs file:
+# (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
+#
+
+# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
+#
+[a/b/c]
+# all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
+# quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
+# fast:scheduled:sync-prepend cron= 0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
+
+# [scriptinc ./gentargets.sh #{getenv USER}]
+# [v1.23/45/67]
+
+# tip will be replaced with hashkey?
+
+# [%/%/%] doesn't work
+
+[/.*/]
+
+[v1.65/tip/dev]
+# file: files changes since last run trigger new run
+# script: script is called with unix seconds as last parameter (other parameters are preserved)
+#
+# contour:sensetype:action params data
+# commented out for debug
+
+quick:file:run runtrans=auto; glob=/nfs/orion/disk1/mfs_home/home/matt/automation_areas/megatest/*.scm foo.touchme
+# snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm
+# short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm
+
+# script returns change-time (unix epoch), new-target-name, run-name
+#
+# quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\
+# checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk
+
+# # fossil based trigger
+# #
+quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.65;\
+ http://www.kiatoa.com/fossils/megatest_qa=trunk
+
+# field allowed values
+# ----- --------------
+# minute 0-59
+# hour 0-23
+# day of month 1-31
+# month 1-12 (or names, future development)
+# day of week 0-7 (0 or 7 is Sun, or, future development, use names)
+
+# actions:
+# run - run a testsuite
+# clean - clear out runs
+# archive - archive runs
+
+# quick:scheduled:run cron=47 * * * * ;run-name=auto
+# quick:scheduled:archive cron=15 20 * * * ;run-name=%;target=%/%/%
+
+# [%]
+# # every friday at midnight clean "all" tests over 7d
+# all:scheduled:clean cron= 0 0 0 0 5;run-name=%;age=7d
+
+[v1.65/tip/dev]
+# # file: files changes since last run trigger new run
+# # script: script is called with unix seconds as last parameter (other parameters are preserved)
+# #
+# # contour:sensetype:action params data
+# quick:file:run run-name=auto;glob=*.scm
+# quick:file:clean run-name=auto;
+# quick:script:run run-name=auto;script=checkfossil.sh v1.63
+#
+# # field allowed values
+# # ----- --------------
+# # minute 0-59
+# # hour 0-23
+# # day of month 1-31
+# # month 1-12 (or names, future development)
+# # day of week 0-7 (0 or 7 is Sun, or, future development, use names)
+#
+# # actions:
+# # run - run a testsuite
+# # clean - clear out runs
+# # archive - archive runs
+#
+quick:scheduled:run cron=47 * * * * ;run-name=auto
+# quick:scheduled:archive cron=15 20 * * * ;run-name=% ;
+#
+
+[%/%/%]
+# # every friday at midnight clean "all" tests over 7d
+all:scheduled:clean cron= 0 0 0 0 5;run-name=%;age=7d
+#
ADDED autostuff/setup.sh
Index: autostuff/setup.sh
==================================================================
--- /dev/null
+++ autostuff/setup.sh
@@ -0,0 +1,2 @@
+source /opt/chicken/4.13.0_18.04_WW45/setup-chicken4x.sh
+export PATH=/mfs/home/matt/orion_automation/bin:$PATH
ADDED chicken.makefile
Index: chicken.makefile
==================================================================
--- /dev/null
+++ chicken.makefile
@@ -0,0 +1,157 @@
+
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# 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 .
+
+
+#======================================================================
+# Chicken build
+#======================================================================
+
+# CHICKEN_BIN_DIR=$(shell dirname $(shell which csi))
+# if have csi on path use that, else use default
+# CSIPATH=$(shell which csi)
+# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
+sCHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR))
+
+whatever :
+ @echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)"
+
+tgz-$(USER)/postgresql-9.6.4.tar.gz :
+ mkdir -p tgz-$(USER)
+ wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz
+ mv postgresql-9.6.4.tar.gz tgz-$(USER)/
+
+tgz-$(USER)/sqlite-autoconf-3090200.tar.gz :
+ mkdir -p tgz-$(USER)
+ curl http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz > tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
+
+tgz-$(USER)/nanomsg-1.0.0.tar.gz :
+ wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz
+ mv 1.0.0.tar.gz tgz-$(USER)/nanomsg-1.0.0.tar.gz
+
+tgz-$(USER)/chicken-4.13.0.tar.gz :
+ mkdir -p tgz-$(USER)
+ curl https://code.call-cc.org/releases/4.13.0/chicken-4.13.0.tar.gz > tgz-$(USER)/chicken-4.13.0.tar.gz
+
+tgz-$(USER)/ffcall.tar.gz :
+ wget -c -O tgz-$(USER)/ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk'
+
+$(CHICKEN_PREFIX)/bin/pg_config : tgz-$(USER)/postgresql-9.6.4.tar.gz
+ mkdir -p build-$(USER)/
+ tar xfz tgz-$(USER)/postgresql-9.6.4.tar.gz -C build-$(USER)
+ cd build-$(USER)/postgresql-9.6.4; ./configure --prefix=$(CHICKEN_PREFIX) --with-openssl; make; make install
+
+build-$(USER)/sqlite-autoconf-3090200/configure : tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
+ mkdir -p build-$(USER);
+ cd build-$(USER); tar xf ../tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
+
+$(CHICKEN_PREFIX)/lib/libnanomsg.so : tgz-$(USER)/nanomsg-1.0.0.tar.gz
+ cd tgz-$(USER); tar -xzvf nanomsg-1.0.0.tar.gz
+ cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER);
+ cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX)
+ cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install
+
+$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz
+ mkdir -p build-$(USER)/eggs-installed
+ cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz
+
+tgz-$(USER)/opensrc.fossil :
+ cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+ mkdir tgz-$(USER)/opensrc
+ cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync
+
+$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil
+ cd tgz-$(USER)/opensrc; fossil unversioned cat libs/cd/cd-5.10_Linux26g4_64_lib.tar.gz > ../cd.tgz
+ cd tgz-$(USER)/opensrc; fossil unversioned cat libs/im/im-3.11_Linux26g4_64_lib.tar.gz > ../im.tgz
+ cd tgz-$(USER)/opensrc; fossil unversioned cat libs/iup/iup-3.19.1_Linux26g4_64_lib.tar.gz > ../iup.tgz
+ cd tgz-$(USER); tar -xzf cd.tgz;
+ cd tgz-$(USER); tar -xzf im.tgz;
+ cd tgz-$(USER); tar -xzf iup.tgz;
+ cp tgz-$(USER)/include/* $(CHICKEN_PREFIX)/include/
+ cp tgz-$(USER)/*.so $(CHICKEN_PREFIX)/lib/
+ cp tgz-$(USER)/*.a $(CHICKEN_PREFIX)/lib/
+ cp tgz-$(USER)/ftgl/lib/*/* $(CHICKEN_PREFIX)/lib/
+
+EGGS=srfi-69 srfi-42 sqlite3 iup canvas-draw typed-records md5 regex-case base64 \
+format dot-locking csv-xml z3 udp hostinfo directory-utils stack dbi crypt sha1 \
+posix-extras pathname-expand csv call-with-environment-variables s11n spiffy \
+uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing \
+ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19 sparse-vectors \
+sql-de-lite fmt readline apropos json simple-exceptions rpc trace logpro refdb postgresql nanomsg
+EGGSTARG=$(addsuffix .done,$(addprefix build-$(USER)/eggs-installed/,$(EGGS)))
+EGGSTARG2=$(addsuffix .done, $(EGGS))
+
+$(CHICKEN_PREFIX)/lib/libcallback.a : tgz-$(USER)/ffcall.tar.gz
+ cd tgz-$(USER); tar -xzvf ffcall.tar.gz
+ cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared
+ cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install
+
+$(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure
+ cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install
+
+$(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE
+ cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX)
+ cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install
+
+ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump \
+chicken-install chicken-profile chicken-sqlite3 chicken-status \
+chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro \
+refdb
+
+CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN))
+
+$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2)
+ utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$*
+ chmod a+x $(PREFIX)/bin/$*
+
+$(PREFIX)/bin :
+ mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin
+
+chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi binwrappers
+ @echo "Fake target to build prefix chicken"
+
+binwrappers : $(CKBIN_WRAPPERS)
+
+postgresql.done : $(CHICKEN_PREFIX)/bin/pg_config
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done
+
+nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done
+
+iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done
+
+canvas-draw.done :
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done
+
+sqlite3.done :
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done
+
+sql-de-lite.done :
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done
+
+dbi.done : postgresql.done sqlite3.done sql-de-lite.done
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done
+
+%.done :
+ $(CHICKEN_PREFIX)/bin/chicken-install $* > $*.done
+
+build-$(USER)/eggs-installed/%.done : $(CHICKEN_PREFIX)/bin/csi $(EGGS)
+ $(CHICKEN_PREFIX)/bin/chicken-install $* > build-$(USER)/eggs-installed/$*.done
+
+build-clean :
+ rm -rf build-$(USER) bin
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -20,18 +20,20 @@
(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
format dot-locking csv-xml z3 udp ;; sql-de-lite
hostinfo md5 message-digest typed-records directory-utils stack
matchable regex posix (srfi 18) extras ;; tcp
- (prefix nanomsg nmsg:)
+ ;; (prefix nanomsg nmsg:)
(prefix sqlite3 sqlite3:)
- pkts (prefix dbi dbi:)
+ (prefix dbi dbi:)
)
(declare (unit common))
(declare (uses commonmod))
-(import commonmod)
+(import (prefix commonmod cmod:))
+
+(import pkts)
(include "common_records.scm")
;; (require-library margs)
@@ -226,10 +228,32 @@
(fullpath (realpath this-script)))
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*))
+
+;; when called from a wrapper I need sometimes to find the calling
+;; wrapper, this is for dashboard to find the correct megatest.
+;;
+(define (common:find-local-megatest #!optional (progname "megatest"))
+ (let ((res (filter file-exists?
+ (map (lambda (updir)
+ (let* ((lm (car (argv)))
+ (dir (pathname-directory lm))
+ (exe (pathname-strip-directory lm)))
+ (conc (if dir (conc dir "/") "")
+ (case (string->symbol exe)
+ ((dboard) (conc updir progname))
+ ((mtest) (conc updir progname))
+ ((dashboard) progname)
+ (else exe)))))
+ '("../../" "../")))))
+ (if (null? res)
+ (begin
+ (debug:print 0 *current-log-port* "Failed to find this executable! Using what can be found on the path")
+ progname)
+ (car res))))
(define *common:logpro-exit-code->status-sym-alist*
'( ( 0 . pass )
( 1 . fail )
( 2 . warn )
@@ -484,13 +508,14 @@
(directory-fold
(lambda (file rem)
(handle-exceptions
exn
(begin
- (debug:print-info 0 *default-log-port* "unable to rotate log " file ", probably handled by another process.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port)))
+ (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore.")
+ (debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print-call-chain (current-error-port)) ;;
+ )
(let* ((fullname (conc "logs/" file))
(mod-time (file-modification-time fullname))
(file-age (- (current-seconds) mod-time)))
(hash-table-set! all-files file mod-time)
(if (or (and (string-match "^.*.log" file)
@@ -691,14 +716,18 @@
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
+ (let ((fmod-time (handle-exceptions
+ ext
+ (current-seconds)
+ (file-modification-time fname))))
(if (common:file-exists? fname)
- (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
+ (if (> (- (current-seconds) fmod-time) expire-time)
(begin
- (handle-exceptions exn #f (delete-file* fname))
+ (handle-exceptions exn #f (delete-file* fname))
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
@@ -708,11 +737,11 @@
(handle-exceptions exn
#f
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line)))))
- #f))))
+ #f)))))
(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
(let ((end-time (+ expire-time (current-seconds))))
(let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
(if got-lock
@@ -873,16 +902,36 @@
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
- (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
- (configf:lookup *configdat* "setup" "testsuite" )
- (getenv "MT_TESTSUITE_NAME")
- (if (string? *toppath* )
- (pathname-file *toppath*)
- #f))) ;; (pathname-file (current-directory)))))
+ (cmod:get-testsuite-name *toppath* *configdat*))
+
+;; safe getting of toppath
+(define (common:get-toppath areapath)
+ (or *toppath*
+ (if areapath
+ (begin
+ (set! *toppath* areapath)
+ (setenv "MT_RUN_AREA_HOME" areapath)
+ areapath)
+ #f)
+ (if (getenv "MT_RUN_AREA_HOME")
+ (begin
+ (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
+ *toppath*)
+ #f)
+ ;; last resort, look for megatest.config
+ (let loop ((thepath (realpath ".")))
+ (if (file-exists? (conc thepath "/megatest.config"))
+ thepath
+ (if (equal? thepath "/")
+ (begin
+ (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.")
+ #f)
+ (loop (pathname-directory thepath)))))
+ ))
(define common:get-area-name common:get-testsuite-name)
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
@@ -1172,11 +1221,23 @@
;;
(define (common:bash-glob instr)
(string-split
(with-input-from-pipe
(conc "/bin/bash -c \"echo " instr "\"")
- read-line)))
+ read-line)))
+
+;;======================================================================
+;; Some safety net stuff
+;;======================================================================
+
+;; return input if it is a list or return null
+(define (common:list-or-null inlst #!key (ovrd #f)(message #f))
+ (if (list? inlst)
+ inlst
+ (begin
+ (if message (debug:print-error 0 *default-log-port* message))
+ (or ovrd '()))))
;;======================================================================
;; T A R G E T S , S T A T E , S T A T U S ,
;; R U N N A M E A N D T E S T P A T T
;;======================================================================
@@ -1277,13 +1338,18 @@
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
- (if *toppath*
- (conc *toppath* "/lt")
- #f))))
+ #f)
+ (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
+ (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
+ #f)
+ (let* ((tp (common:get-toppath #f))
+ (lt (conc tp "/lt")))
+ (if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
+ lt)))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
@@ -1586,29 +1652,17 @@
))))))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (common:lazy-convert inval)
- (let* ((as-num (if (string? inval)(string->number inval) #f)))
- (or as-num inval)))
+ (cmod:lazy-convert inval))
;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (common:val->alist val #!key (convert #f))
- (let ((val-list (string-split-fields ";\\s*" val #:infix)))
- (if val-list
- (map (lambda (x)
- (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
- (case (length f)
- ((0) `(,#f)) ;; null string case
- ((1) `(,(string->symbol (car f))))
- ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
- (if convert (common:lazy-convert inval) inval))))
- (else f))))
- val-list)
- '())))
+ (cmod:val->alist val #!key (convert #f)))
;;======================================================================
;; S Y S T E M S T U F F
;;======================================================================
@@ -1672,43 +1726,61 @@
;; cpu-load))
;; get values from cached info from dropping file in logs dir
;; e.g. key is host and dtype is normalized-load
;;
-(define (common:get-cached-info key dtype #!key (age 5))
- (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")))
- (if (and (file-exists? fullpath)
- (file-read-access? fullpath))
- (handle-exceptions
- exn
- #f
- (debug:print 2 *default-log-port* "reading file " fullpath)
- (let ((real-age (- (current-seconds)(file-change-time fullpath))))
- (if (< real-age age)
- (with-input-from-file fullpath read)
- (begin
- (debug:print 1 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it")
- #f))))
- (begin
- (debug:print 2 *default-log-port* "not reading file " fullpath)
- #f))))
-
-(define (common:write-cached-info key dtype dat)
- (let* ((fulldir (conc *toppath* "/.sysdata"))
- (fullpath (conc fulldir "/" key "-" dtype ".log")))
- (if (not (file-exists? fulldir))(create-directory fulldir #t))
- (handle-exceptions
- exn
- #f
- (with-output-to-file fullpath (lambda ()(pp dat))))))
+(define (common:get-cached-info key dtype #!key (age 10))
+ (if *toppath*
+ (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")))
+ (if (and (file-exists? fullpath)
+ (file-read-access? fullpath))
+ (handle-exceptions
+ exn
+ #f
+ (debug:print 2 *default-log-port* "reading file " fullpath)
+ (let ((real-age (- (current-seconds)(file-change-time fullpath))))
+ (if (< real-age age)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 1 *default-log-port* " removing bad file " fullpath)
+ (delete-file* fullpath)
+ #f)
+ (with-input-from-file fullpath read))
+ (begin
+ (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it")
+ #f))))
+ (begin
+ (debug:print 2 *default-log-port* "not reading file " fullpath)
+ #f)))
+ #f))
+
+(define (common:write-cached-info key dtype dat)
+ (if *toppath*
+ (let* ((fulldir (conc *toppath* "/.sysdata"))
+ (fullpath (conc fulldir "/" key "-" dtype ".log")))
+ (if (not (file-exists? fulldir))(create-directory fulldir #t))
+ (handle-exceptions
+ exn
+ #f
+ (with-output-to-file fullpath (lambda ()(pp dat)))))
+ #f))
+
+(define (common:raw-get-remote-host-load remote-host)
+ (handle-exceptions
+ exn
+ #f ;; more specific handling of errors needed
+ (with-input-from-pipe
+ (conc "ssh " remote-host " cat /proc/loadavg")
+ (lambda ()(list (read)(read)(read))))))
;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)
(handle-exceptions
exn
- '(99 99 99)
+ '(-99 -99 -99)
(let* ((actual-hostname (or remote-host (get-host-name) "localhost")))
(or (common:get-cached-info actual-hostname "cpu-load")
(let ((result (if remote-host
(map (lambda (res)
(if (eof-object? res) 9e99 res))
@@ -1715,12 +1787,21 @@
(with-input-from-pipe
(conc "ssh " remote-host " cat /proc/loadavg")
(lambda ()(list (read)(read)(read)))))
(with-input-from-file "/proc/loadavg"
(lambda ()(list (read)(read)(read)))))))
- (common:write-cached-info actual-hostname "cpu-load" result)
- result)))))
+ (match
+ result
+ ((l1 l2 l3)
+ (if (and (number? l1)
+ (number? l2)
+ (number? l3))
+ (begin
+ (common:write-cached-info actual-hostname "cpu-load" result)
+ result)
+ '(-1 -1 -1))) ;; -1 is bad result
+ (else '(-2 -2 -2))))))))
;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
@@ -1935,59 +2016,96 @@
(or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) ;; hosts had better not be changing the number of cpus too often!
(let* ((proc (lambda ()
(let loop ((numcpu 0)
(inl (read-line)))
(if (eof-object? inl)
- (begin
- (common:write-cached-info actual-host "num-cpus" numcpu)
- numcpu)
+ (if (> numcpu 0)
+ numcpu
+ #f) ;; if zero return #f so caller knows that things are not working
(loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
(+ numcpu 1)
numcpu)
(read-line))))))
(result (if remote-host
(with-input-from-pipe
(conc "ssh " remote-host " cat /proc/cpuinfo")
proc)
(with-input-from-file "/proc/cpuinfo" proc))))
- (common:write-cached-info actual-host "num-cpus" result)
+ (if (and (number? result)
+ (> result 0))
+ (common:write-cached-info actual-host "num-cpus" result))
result))))
;; wait for normalized cpu load to drop below maxload
;;
-(define (common:wait-for-normalized-load maxload msg remote-host)
+(define (common:wait-for-normalized-load maxload msg remote-host #!optional (rem-tries 5))
(let ((num-cpus (common:get-num-cpus remote-host)))
- (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))
+ (if num-cpus
+ (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)
+ (begin
+ (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again
+ (if (> rem-tries 0)
+ (common:wait-for-normalized-load maxload msg remote-host (- rem-tries 1))
+ #f)))))
;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
;;
-(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f))
+(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
(let* ((loadavg (common:get-cpu-load remote-host))
(numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again
(common:get-num-cpus remote-host)
numcpus-in))
(maxload (if force-maxload
maxload-in
- (max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
+ (if (number? maxload-in)
+ (max maxload-in 0.5)
+ 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
(first (car loadavg))
(next (cadr loadavg))
- (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
+ (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
+ ;; numcpus (or could be
+ ;; maxload) is zero,
+ ;; crude fallback is to
+ ;; at least use 1
(loadjmp (- first next))
- (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) )) )));; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
- (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
- ", load: " first ", adjload: " adjload ", loadjmp: " loadjmp)
+ ;; add some randomness to the time to break any alignment
+ ;; where netbatch dumps many jobs to machines simultaneously
+ (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)
+ (/ (- 1000 count) 10)
+ waitdelay)
+ (- first adjmaxload) )) )))
+ ;; let's let the user know once in a long while that load checking
+ ;; is happening but not constantly report it
+ (if (> (random 100) 75) ;; about 25% of the time
+ (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
+ ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
(cond
- ((and (> first adjload)
+ ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
+ (> num-tries 0))
+ (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
+ (thread-sleep! 10)
+ (common:wait-for-cpuload maxload-in numcpus-in waitdelay
+ count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
+ ((and (> first adjmaxload)
(> count 0))
- (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
+ (debug:print-info 0 *default-log-port*
+ "server start delayed " adjwait
+ " seconds due to load " first
+ " exceeding max of " adjmaxload
+ " on server " (or remote-host (get-host-name))
+ " (normalized load-limit: " maxload ") " (if msg msg ""))
(thread-sleep! adjwait)
(common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
((and (> loadjmp numcpus)
(> count 0))
(debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
(thread-sleep! adjwait)
- (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))
+ (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
+ (else
+ (if (> num-tries 0)
+ (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing.")
+ (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
(define (get-uname . params)
(let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
(uname #f))
(if (null? (car uname-res))
@@ -2084,12 +2202,13 @@
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
(let* ((required (string->number
+ ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks.
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
- "100000")))
+ "1000000")))
(dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
(mdbspace (common:check-space-in-dir *toppath* required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
@@ -2108,13 +2227,16 @@
(exit 1)))))
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
- (let ((best #f)
+ (let* ((best #f)
(bestsize 0)
- (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") "0")) 0)))
+ (default-min-inodes-string "1000000")
+ (default-min-inodes (string->number default-min-inodes-string))
+ (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes)))
+
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (cond
((not (directory? dirpath))
@@ -2146,10 +2268,11 @@
-1)
(else
(get-free-inodes dirpath))))
;;(free-inodes (get-free-inodes dirpath))
)
+ (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes)
(if (and (> freespc bestsize)(> free-inodes min-inodes ))
(begin
(set! best (cons disk-num dirpath))
(set! bestsize freespc)))
;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes)
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -21,13 +21,129 @@
(declare (unit commonmod))
(module commonmod
*
-(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+(import scheme chicken data-structures extras files)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
+ md5 message-digest
+ regex srfi-1)
+
+;;======================================================================
+;; CONTENTS
+;;
+;; config file utils
+;; misc conversion, data manipulation functions
+;; testsuite and area utilites
+;;
+;;======================================================================
+
+;;======================================================================
+;; config file utils
+;;======================================================================
+
+(define (lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
+
+;; returns var key1=val1; key2=val2 ... as alist
+(define (get-key-list cfgdat section var)
+ ;; convert string a=1; b=2; c=a silly thing; d=
+ (let ((valstr (lookup cfgdat section var)))
+ (if valstr
+ (val->alist valstr)
+ '()))) ;; should it return empty list or #f to indicate not set?
+
+
+(define (get-section cfgdat section)
+ (hash-table-ref/default cfgdat section '()))
+
+;;======================================================================
+;; misc conversion, data manipulation functions
+;;======================================================================
+
+;; if it looks like a number -> convert it to a number, else return it
+;;
+(define (lazy-convert inval)
+ (let* ((as-num (if (string? inval)(string->number inval) #f)))
+ (or as-num inval)))
+
+;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
+;;
+(define (val->alist val #!key (convert #f))
+ (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+ (if val-list
+ (map (lambda (x)
+ (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+ (case (length f)
+ ((0) `(,#f)) ;; null string case
+ ((1) `(,(string->symbol (car f))))
+ ((2) `(,(string->symbol (car f)) .
+ ,(let ((inval (cadr f)))
+ (if convert (lazy-convert inval) inval))))
+ (else f))))
+ (filter (lambda (x)
+ (not (string-match "^\\s*" x)))
+ val-list))
+ '())))
+
+;;======================================================================
+;; testsuite and area utilites
+;;======================================================================
+
+(define (get-testsuite-name toppath configdat)
+ (or (lookup configdat "setup" "area-name")
+ (lookup configdat "setup" "testsuite")
+ (get-environment-variable "MT_TESTSUITE_NAME")
+ (if (string? toppath)
+ (pathname-file toppath)
+ #f)))
+
+(define (get-area-path-signature toppath #!optional (short #f))
+ (let ((res (message-digest-string (md5-primitive) toppath)))
+ (if short
+ (substring res 0 4)
+ res)))
+
+(define (get-area-name configdat toppath #!optional (short #f))
+ ;; look up my area name in areas table (future)
+ ;; generate auto name
+ (conc (get-area-path-signature toppath short)
+ "-"
+ (get-testsuite-name toppath configdat)))
+
+;; need generic find-record-with-var-nmatching-val
+;;
+(define (path->area-record cfgdat path)
+ (let* ((areadat (get-cfg-areas cfgdat))
+ (all (filter (lambda (x)
+ (let* ((keyvals (cdr x))
+ (pth (alist-ref 'path keyvals)))
+ (equal? path pth)))
+ areadat)))
+ (if (null? all)
+ #f
+ (car all)))) ;; return first match
+;; given a config return an alist of alists
+;; area-name => data
+;;
+(define (get-cfg-areas cfgdat)
+ (let ((adat (get-section cfgdat "areas")))
+ (map (lambda (entry)
+ `(,(car entry) .
+ ,(val->alist (cadr entry))))
+ adat)))
+
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -9,11 +9,11 @@
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
+;; GNnU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
@@ -20,15 +20,18 @@
;;======================================================================
;; Config file handling
;;======================================================================
-(use regex regex-case) ;; directory-utils)
+(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
+(declare (uses commonmod))
+
+(import (prefix commonmod cmod:))
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
@@ -118,14 +121,15 @@
" (let ((extra \"" cmd "\"))"
" (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
" (if (string-null? extra) \"\" \"/\")"
" extra)))"))
((get g)
- (let* ((parts (string-split cmd))
- (sect (car parts))
- (var (cadr parts)))
- (conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
+ (match (string-split cmd)
+ ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ "(lambda (ht) #f)")))
((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(handle-exceptions
@@ -189,11 +193,11 @@
((return-string)
inl)
(else
(configf:process-line inl ht allow-processing)))))
(if (and (string? res)
- (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "yes")))
(string-substitute "\\s+$" "" res)
res))))))
(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
(filter
@@ -498,33 +502,24 @@
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
-(define (configf:lookup cfgdat section var)
- (if (hash-table? cfgdat)
- (let ((sectdat (hash-table-ref/default cfgdat section '())))
- (if (null? sectdat)
- #f
- (let ((match (assoc var sectdat)))
- (if match ;; (and match (list? match)(> (length match) 1))
- (cadr match)
- #f))
- ))
- #f))
-
;; use to have definitive setting:
;; [foo]
;; var yes
;;
;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (configf:var-is? cfgdat section var expected-val)
(equal? (configf:lookup cfgdat section var) expected-val))
-(define config-lookup configf:lookup)
+;; (define config-lookup configf:lookup)
(define configf:read-file read-config)
+
+(define (configf:lookup cfgdat section var)
+ (cmod:lookup cfgdat section var))
;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfdat section varname #!key (default #f))
ADDED configure
Index: configure
==================================================================
--- /dev/null
+++ configure
@@ -0,0 +1,100 @@
+#!/bin/bash
+
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# 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 .
+
+# Configure the build
+
+if [[ "$1"x == "x" ]];then
+ PREFIX=$PWD
+else
+ PREFIX=$1
+fi
+
+
+#======================================================================
+# Configure stuff needed for eggs
+#======================================================================
+
+function configure_dependencies () {
+
+ #======================================================================
+ # libnanomsg
+ #======================================================================
+
+ if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
+ echo "libnanomsg build needed."
+ echo "BUILD_NANOMSG=yes" >> makefile.inc
+ fi
+
+ #======================================================================
+ # postgresql libraries
+ #======================================================================
+
+ if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
+ echo "Postgresql build needed."
+ echo "BUILD_POSTGRES=yes" >> makefile.inc
+ fi
+
+ if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
+ echo "Sqlite3 build needed."
+ echo "BUILD_SQLITE3=yes" >> makefile.inc
+ fi
+
+}
+
+#======================================================================
+# Initialize makefile.inc
+#======================================================================
+
+echo "" > makefile.inc
+
+#======================================================================
+# Do we need Chicken?
+#======================================================================
+
+if [[ -e /usr/bin/sw_vers ]]; then
+ ARCHSTR=$(/usr/bin/sw_vers -productVersion)
+else
+ ARCHSTR=$(lsb_release -sr)
+fi
+
+echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
+CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR
+
+if [[ ! $(type csi) ]];then
+ echo "Chicken build needed."
+ echo "BUILD_CHICKEN=yes" >> makefile.inc
+ configure_dependencies
+ echo "include chicken.makefile" >> makefile.inc
+else
+ echo "CSIPATH=$(which csi)" >> makefile.inc
+ echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
+fi
+
+# Make setup scripts
+echo "#!/bin/bash" > setup.sh
+echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
+echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
+echo 'exec "$@"' >> setup.sh
+chmod a+x setup.sh
+
+echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
+echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh
+
+echo "All done creating makefile.inc, feel free to edit it!"
+echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"
ADDED cookie.scm
Index: cookie.scm
==================================================================
--- /dev/null
+++ cookie.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; 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 .
+
+;;======================================================================
+
+(declare (unit cookie))
+
+(include "stml2/cookie.scm")
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -45,20 +45,13 @@
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (dboard:launch-testpanel run-id test-id)
- (let* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh"))
- ;; (cmd (conc
- ;; (if (common:file-exists? cfg-sh)
- ;; (conc "source "cfg-sh" && ")
- ;; "")
- ;; *common:this-exe-fullpath*
- ;; " -test " run-id "," test-id
- ;; " &"))
- (cmd (conc *common:this-exe-dir*"/../dashboard "
- "-test " run-id "," test-id
+ (let* ((dboardexe (common:find-local-megatest "dashboard"))
+ (cmd (conc dboardexe
+ " -test " run-id "," test-id
" &")))
(system cmd)))
(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -23,11 +23,11 @@
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use ducttape-lib)
+(import ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses margs))
@@ -47,10 +47,15 @@
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))
+(declare (uses dbmod))
+(import (prefix dbmod dbmod:))
+(declare (uses commonmod))
+(import (prefix commonmod cmod:))
+
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-fossil-hash.scm")
@@ -97,10 +102,11 @@
"-q"
"-use-db-cache"
"-skip-version-check"
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
+ "-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
;; check for MT_* environment variables and exit if found
@@ -431,10 +437,76 @@
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
+
+;; for the new runs view lets build up a few new record types and then consolidate later
+;;
+;; this is a two level deep pipeline for the incoming data:
+;; sql query data ==> filters ==> data for display
+;;
+(defstruct dboard:rdat
+ ;; view related items
+ (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
+ (leftcol 0) ;; number of the leftmost visible column
+ (toprow 0) ;; topmost visible row
+ (numcols 24) ;; number of columns visible
+ (numrows 20) ;; number of rows visible
+
+ ;; data from sql db
+ (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
+ (runs (make-sparse-vector)) ;; id => runrec
+ (runsbynum (make-vector 100 #f)) ;; vector num => runrec
+ (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
+ (tests (make-hash-table)) ;; test[/itempath] => list of test rec
+
+ ;; run sql filters
+ (targ-sql-filt "%")
+ (runname-sql-filt "%")
+ (run-state-sql-filt "%")
+ (run-status-sql-filt "%")
+
+ ;; test sql filter
+ (testname-sql-filt "%")
+ (itempath-sql-filt "%")
+ (test-state-sql-filt "%")
+ (test-status-sql-filt "%")
+
+ ;; other sql related fields
+ (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
+
+ ;; filtered data
+ (cols (make-sparse-vector)) ;; columnnum => run-id
+ (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec)
+
+ ;; various
+ (prev-run-ids '()) ;; push previously looked at runs on this
+ (view-changed #f)
+
+ ;; widgets
+ (runs-tree #f) ;;
+ )
+
+(define (dboard:rdat-push-run-id rdat run-id)
+ (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
+
+(defstruct dboard:runrec
+ id
+ target ;; a/b/c...
+ tdef ;; for future use
+ )
+
+(defstruct dboard:testrec
+ id
+ runid
+ testname ;; test[/itempath]
+ state
+ status
+ start-time
+ duration
+ )
;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
(cons dboard:rundat?
@@ -1456,40 +1528,53 @@
;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
(define (dboard:runs-tree-browser commondat tabdat)
- (let* (
- (txtbox (iup:textbox #:action (lambda (val a b)
- (debug:catch-and-dump
- (lambda ()
- ;; for the Runs view we put the list of keyvals into tabdat target
- ;; for the Run Controls we put then update the run-command
- (if b (dboard:tabdat-target-set! tabdat (string-split b "/")))
- (dashboard:update-run-command tabdat))
- "command-testname-selector tb action"))
- #:value (dboard:test-patt->lines
- (dboard:tabdat-test-patts-use tabdat))
- #:expand "HORIZONTAL"
- ;; #:size "10x30"
- ))
+ (let* ((txtbox (iup:textbox
+ #:action (lambda (val a b)
+ (debug:catch-and-dump
+ (lambda ()
+ ;; for the Runs view we put the list
+ ;; of keyvals into tabdat target for
+ ;; the Run Controls we put then update
+ ;; the run-command
+ (if b (dboard:tabdat-target-set! tabdat
+ (string-split b "/")))
+ (dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ #:value (dboard:test-patt->lines
+ (dboard:tabdat-test-patts-use tabdat))
+ #:expand "HORIZONTAL"
+ ;; #:size "10x30"
+ ))
(tb
(iup:treebox
#:value 0
- #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed:Â [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
+ #:title "Runs" ;; was #:name -- iup 3.19 changed
+ ;; this... "Changed:Â [DEPRECATED
+ ;; REMOVED] removed the old attribute
+ ;; NAMEid from IupTree to avoid
+ ;; conflict with the common attribute
+ ;; NAME. Use the TITLEid attribute."
#:expand "YES"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id tabdat (cdr run-path))))
- ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
- (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
- (iup:attribute-set! txtbox "VALUE" (string-intersperse (cdr run-path) "/"))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
+ ;; done below when run-id is a number
+ (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print
+ ;; "run-path:
+ ;; "
+ ;; run-path)
+ (iup:attribute-set! txtbox "VALUE"
+ (string-intersperse (cdr run-path) "/"))
(dashboard:update-run-command tabdat)
(dboard:tabdat-layout-update-ok-set! tabdat #f)
(if (number? run-id)
(begin
;; capture last two in tabdat.
@@ -1503,12 +1588,80 @@
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:detachbox
(iup:vbox
+ txtbox
+ tb
+ ))))
+
+;; browse runs as a tree. Used in both "Runs" tab and
+;; in the runs control panel.
+;;
+;; THIS IS THE NEW ONE
+;;
+(define (dboard:runs-tree-new-browser commondat rdat)
+ (let* ((txtbox (iup:textbox
+ #:action (lambda (val a b)
+ (debug:catch-and-dump
+ (lambda ()
+ ;; for the Runs view we put the list
+ ;; of keyvals into tabdat target for
+ ;; the Run Controls we put then update
+ ;; the run-command
+ (if b (dboard:rdat-targ-sql-filt-set! rdat
+ (string-split b "/")))
+ #;(dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from?
+ ;; (dboard:tabdat-test-patts-use tabdat))
+ #:expand "HORIZONTAL"
+ ;; #:size "10x30"
+ ))
+ (tb
+ (iup:treebox
+ #:value 0
+ #:title "Runs" ;; was #:name -- iup 3.19 changed
+ ;; this... "Changed:Â [DEPRECATED
+ ;; REMOVED] removed the old attribute
+ ;; NAMEid from IupTree to avoid
+ ;; conflict with the common attribute
+ ;; NAME. Use the TITLEid attribute."
+ #:expand "YES"
+ #:addexpanded "YES"
+ #:size "10x"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (new-tree-path->run-id rdat (cdr run-path))))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
+ ;; done below when run-id is a number
+ (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
+ ;; "run-path:
+ ;; "
+ ;; run-path)
+ (iup:attribute-set! txtbox "VALUE"
+ (string-intersperse (cdr run-path) "/"))
+ #;(dashboard:update-run-command tabdat)
+ #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (if (number? run-id)
+ (begin
+ ;; capture last two in tabdat.
+ (dboard:rdat-push-run-id rdat run-id)
+ (dboard:rdat-view-changed-set! rdat #t))
+ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
+ "treebox"))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
+ (dboard:rdat-runs-tree-set! rdat tb)
+ (iup:detachbox
+ (iup:vbox
+ txtbox
tb
- txtbox))))
+ ))))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
@@ -1674,10 +1827,15 @@
(define (tree-path->run-id tabdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
+
+(define (new-tree-path->run-id rdat path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
+ #f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;; run-id
@@ -2428,14 +2586,165 @@
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01))
+;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
+;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004)
+;; simple-run-event_time procedure (x3834)
+;; simple-run-event_time-set! procedure (x3830 val3831)
+;; simple-run-id procedure (x3794)
+;; simple-run-id-set! procedure (x3790 val3791)
+;; simple-run-owner procedure (x3826)
+;; simple-run-owner-set! procedure (x3822 val3823)
+;; simple-run-runname procedure (x3802)
+;; simple-run-runname-set! procedure (x3798 val3799)
+;; simple-run-state procedure (x3810)
+;; simple-run-state-set! procedure (x3806 val3807)
+;; simple-run-status procedure (x3818)
+;; simple-run-status-set! procedure (x3814 val3815)
+;; simple-run-target procedure (x3786)
+;; simple-run-target-set! procedure (x3782 val3783)
+;; simple-run? procedure (x3780)
+
+
+;;======================================================================
+;; Extracting the data to display for runs
+;;
+;; This needs to be re-entrant such that it does one column per call
+;; on the zeroeth call update runs data
+;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
+;; on last run reset to zeroeth
+;;
+;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
+;; - put this information into two data structures:
+;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
+;; status, starttime, duration, non-deleted testcount>
+;; ordernum reflects order as received from sql query
+;; b. sparsevec of id => runstruct
+;; 2. for each run in runshash ordered by ordernum do:
+;; retrieve data since last update for that run
+;; if there is a deleted test - retrieve full data
+;; if there are non-deleted tests register this run in the columns sparsevec
+;; if this is the zeroeth column regenerate the rows sparsevec
+;; if this column is in the visible zone update visible cells
+;;
+;; Other factors:
+;; 1. left index handling:
+;; - add test/itempaths to left index as discovered, re-order and
+;; update row -> test/itempath mapping on each read run
+;;======================================================================
+
+;; runs is
+;; get ALL runs info
+;; update rdat-targ-run-id
+;; update rdat-runs
+;;
+(define (dashboard:update-runs-data rdat)
+ (let* ((tb (dboard:rdat-runs-tree rdat))
+ (targ-sql-filt (dboard:rdat-targ-sql-filt rdat))
+ (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
+ (state-sql-filt (dboard:rdat-run-state-sql-filt rdat))
+ (status-sql-filt (dboard:rdat-run-status-sql-filt rdat))
+ ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+ (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
+ (numruns (length data)))
+ ;; store in the runsbynum vector
+ (dboard:rdat-runsbynum-set! rdat (list->vector data))
+ ;; update runs id => runrec
+ ;; update targ-runid target/runname => run-id
+ (for-each
+ (lambda (runrec)
+ (let* ((run-id (simple-run-id runrec))
+ (full-targ-runname (conc (simple-run-target runrec) "/"
+ (simple-run-runname runrec))))
+ (debug:print 0 *default-log-port* "Update run " run-id)
+ (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
+ (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
+ ))
+ data)
+ numruns))
+
+;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
+;;
+(define (dashboard:update-run-data runnum rdat)
+ (let* ((curr-time (current-seconds))
+ (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum))
+ (run-id (simple-run-id runrec))
+ (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
+ ;; filters
+ (testname-sql-filt (dboard:rdat-testname-sql-filt rdat))
+ ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat))
+ (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet
+ (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet
+ (tests (rmt:get-tests-for-run-state-status run-id
+ testname-sql-filt
+ last-update ;; last-update
+ )))
+ (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
+ (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
+ run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update)
+ (length tests)))
+
+(define (new-runs-updater commondat rdat)
+ (let* ((runnum (dboard:rdat-runnum rdat))
+ (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) 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)
+ (dboard:rdat-runnum-set! rdat newrn)
+ (if (> newrn 0)
+ (loop newrn)))))
+ (if (>= (dboard:rdat-runnum rdat) tot-runs)
+ (dboard:rdat-runnum-set! rdat 0))
+ ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
+ ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
+ ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
+ '()))
+
+(define (dboard:runs-new-matrix commondat rdat)
+ (iup:matrix
+ #:alignment1 "ALEFT"
+ ;; #:expand "YES" ;; "HORIZONTAL"
+ #:scrollbar "YES"
+ #:numcol 10
+ #:numlin 20
+ #:numcol-visible 5 ;; (min 8)
+ #:numlin-visible 1
+ #:click-cb
+ (lambda (obj row col status)
+ (let* ((cell (conc row ":" col)))
+ #f))
+ ))
+
+(define (make-runs-view commondat rdat tab-num)
+ ;; register an updater
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (new-runs-updater commondat rdat))
+ tab-num: tab-num)
+
+ (iup:vbox
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 100
+ (dboard:runs-tree-new-browser commondat rdat)
+ (dboard:runs-new-matrix commondat rdat)
+ )))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
+ (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
@@ -2456,59 +2765,83 @@
(cell-width (dboard:tabdat-runs-cell-width runs-dat)))
;; controls (along bottom)
;; (set! controls (dboard:make-controls commondat runs-dat))
;; create the left most column for the run key names and the test names
- (set! lftlst (list (iup:hbox
- (iup:label) ;; (iup:valuator)
- (apply iup:vbox
- (map (lambda (x)
- (let ((res (iup:hbox #:expand "HORIZONTAL"
- (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL")
- (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL"
- #:action (lambda (obj unk val)
- ;; each field (field name is "x" var) live updates
- ;; the search filter as it is typed
- (dboard:tabdat-target-set! runs-dat #f) ;; ensure the fields text boxes are used and not the info from the tree
- (mark-for-update runs-dat)
- (update-search commondat runs-dat x val))))))
- (set! i (+ i 1))
- res))
- keynames)))))
+ (set! lftlst
+ (list (iup:hbox
+ (iup:label) ;; (iup:valuator)
+ (apply iup:vbox
+ (map (lambda (x)
+ (let ((res (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:label x
+ #:size (conc 40 btn-height)
+ #:fontsize btn-fontsz
+ #:expand "NO") ;; "HORIZONTAL")
+ (iup:textbox
+ #:size (conc 35 btn-height)
+ #:fontsize btn-fontsz
+ #:value "%"
+ #:expand "NO" ;; "HORIZONTAL"
+ #:action (lambda (obj unk val)
+ ;; each field
+ ;; (field name is "x" var) live updates
+ ;; the search filter as it is typed
+ (dboard:tabdat-target-set! runs-dat #f)
+ ;; ensure fields text boxes are used
+ ;; and not the info from the tree
+ (mark-for-update runs-dat)
+ (update-search commondat runs-dat x val))))))
+ (set! i (+ i 1))
+ res))
+ keynames)))))
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
- (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
- (iup:valuator #:valuechanged_cb (lambda (obj)
- (let ((val (string->number (iup:attribute obj "VALUE")))
- (oldmax (string->number (iup:attribute obj "MAX")))
- (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
- (dboard:commondat-please-update-set! commondat #t)
- (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
- (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
- (if (< val 10)
- (iup:attribute-set! obj "MAX" newmax))
- ))
- #:expand "VERTICAL"
- #:orientation "VERTICAL"
- #:min 0
- #:step 0.01)
- (apply iup:vbox (reverse res)))))))
+ (set! lftlst
+ (append
+ lftlst
+ (list
+ (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:valuator
+ #:valuechanged_cb
+ (lambda (obj)
+ (let ((val (string->number (iup:attribute obj "VALUE")))
+ (oldmax (string->number (iup:attribute obj "MAX")))
+ (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-start-test-offset-set! runs-dat
+ (inexact->exact (round (/ val 10))))
+ (debug:print 6 *default-log-port*
+ "(dboard:tabdat-start-test-offset runs-dat) "
+ (dboard:tabdat-start-test-offset runs-dat) " val: " val
+ " newmax: " newmax " oldmax: " oldmax)
+ (if (< val 10)
+ (iup:attribute-set! obj "MAX" newmax))
+ ))
+ #:expand "VERTICAL"
+ #:orientation "VERTICAL"
+ #:min 0
+ #:step 0.01)
+ (apply iup:vbox (reverse res)))))))
(else
- (let ((labl (iup:button "" ;; the testname labels
- #:flat "YES"
- #:alignment "ALEFT"
+ (let ((labl (iup:button
+ "" ;; the testname labels
+ #:flat "YES"
+ #:alignment "ALEFT"
; #:image img1
; #:impress img2
- #:size (conc cell-width btn-height)
- #:expand "HORIZONTAL"
- #:fontsize btn-fontsz
- #:action (lambda (obj)
- (mark-for-update runs-dat)
- (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE"))))
+ #:size (conc cell-width btn-height)
+ #:expand "HORIZONTAL"
+ #:fontsize btn-fontsz
+ #:action (lambda (obj)
+ (mark-for-update runs-dat)
+ (toggle-hide testnum (dboard:commondat-uidat commondat))))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
;; These are the headers for each row
(let loop ((runnum 0)
(keynum 0)
@@ -2617,50 +2950,51 @@
(lambda (view-name)
(debug:print 0 *default-log-port* "Adding view " view-name)
(let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view?
(if (not (string? cfgtype))
(debug:print-info 0 *default-log-port* "WARNING: view \"" view-name
- "\" is missing needed sections. Please consult the documenation and update ~/.mtviews.config or " *toppath* "/.mtviews.config")
+ "\" is missing needed sections. "
+ "Please consult the documenation and update ~/.mtviews.config or "
+ *toppath* "/.mtviews.config")
(case (string->symbol cfgtype)
;; user supplied source for a tab
;;
- ((external)
- (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) ;; was tabs
+ ((external) ;; was tabs
+ (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num)))
(set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames))
(set! tab-num (+ tab-num 1))
(set! result (append result (list tab-content)))))))))
- (sort (hash-table-keys views-cfgdat) (lambda (a b)
- (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
- (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
- (> order-a order-b)))))
+ (sort (hash-table-keys views-cfgdat)
+ (lambda (a b)
+ (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
+ (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
+ (> order-a order-b)))))
result))
(tabs (apply iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(debug:catch-and-dump
(lambda ()
(let* ((tab-num (dboard:commondat-curr-tab-num commondat))
(tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
-
(dboard:tabdat-layout-update-ok-set! tabdat #f))
(dboard:commondat-curr-tab-num-set! commondat curr)
(let* ((tab-num (dboard:commondat-curr-tab-num commondat))
(tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
-
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-layout-update-ok-set! tabdat #t)))
"tabchangepos"))
(dashboard:summary commondat stats-dat tab-num: 0)
runs-view
+ ;; (make-runs-view commondat runs2-dat 2)
(dashboard:runs-summary commondat onerun-dat tab-num: 2)
- ;; (dashboard:new-view db data new-view-dat tab-num: 3)
(dashboard:run-controls commondat runcontrols-dat tab-num: 3)
(dashboard:run-times commondat runtimes-dat tab-num: 4)
- ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
additional-views)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
+ ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
(iup:attribute-set! tabs "TABTITLE3" "Run Control")
(iup:attribute-set! tabs "TABTITLE4" "Run Times")
;; (iup:attribute-set! tabs "TABTITLE3" "New View")
;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
@@ -2675,10 +3009,11 @@
;; make the iup tabs object available (for changing color for example)
(dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
;; now set up the tabdat lookup
(dboard:common-set-tabdat! commondat 0 stats-dat)
(dboard:common-set-tabdat! commondat 1 runs-dat)
+ ;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
(dboard:common-set-tabdat! commondat 2 onerun-dat)
(dboard:common-set-tabdat! commondat 3 runcontrols-dat)
(dboard:common-set-tabdat! commondat 4 runtimes-dat)
(iup:vbox
@@ -3418,20 +3753,12 @@
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
- ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
- ;;(tabdat-values tabdat) ;;RA added
- ;; (pp (dboard:tabdat->alist tabdat))
- ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
(dashboard:do-update-rundat tabdat)
- ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
- ;;(inspect tabdat)
-
(let ((uidat (dboard:commondat-uidat commondat)))
- ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;;======================================================================
@@ -3469,10 +3796,15 @@
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 1)
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (dashboard:runs-tab-updater commondat 1))
+ tab-num: 2)
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (time-obj)
(let ((update-is-running #f))
(mutex-lock! (dboard:commondat-update-mutex commondat))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1464,20 +1464,18 @@
(set! res id))
db
"SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
bdisk-id archive-path)
(if res ;; record exists, update du if applicable and return res
- (begin
- (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
+ (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
WHERE archive_disk_id=? AND disk_path=?;"
- bdisk-id archive-path du))
- res)
+ bdisk-id archive-path du))
(begin
(sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
VALUES (?,?,?);"
bdisk-id archive-path (or du 0))
- (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))
+ (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
res))
;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
@@ -1614,10 +1612,30 @@
;; given a launch delay (minimum time from last launch) return amount of time to wait
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
+
+
+(define (db:get-status-from-final-status-file run-dir)
+ (let (
+ (infile (conc run-dir "/.final-status")))
+
+ ;; first verify we are able to write the output file
+ (if (not (file-read-access? infile))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
+ (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
+ #f
+ )
+ (with-input-from-file infile read-lines)
+ )
+ )
+)
+
+
+
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
@@ -1624,10 +1642,12 @@
(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
+ ;; The default running-deadtime is 720 seconds = 12 minutes.
+ ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
(deadtime-trim (or ovr-deadtime (configf:lookup-number *configdat* "setup" "deadtime")))
(server-start-allowance 200)
(server-overloaded-budget 200)
(launch-monitor-off-time (or (configf:lookup-number *configdat* "setup" "test-stats-update-period") 30))
(launch-monitor-on-time-budget 30)
@@ -1635,10 +1655,13 @@
(remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
(remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
(running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
)
+ (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
+ (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
+
(db:with-db
dbstruct #f #f
(lambda (db)
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
@@ -1657,12 +1680,13 @@
(debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
(begin
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))
(debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration))))
db
+
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING');"
- run-id running-deadtime)
+ run-id running-deadtime) ;; default time 720 seconds
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path event-time run-duration)
(if (and (equal? uname "n/a")
@@ -1674,11 +1698,11 @@
(begin
(debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration)
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))
db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('REMOTEHOSTSTART');"
- run-id remotehoststart-deadtime)
+ run-id remotehoststart-deadtime) ;; default time 230 seconds
;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
;;
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
@@ -1708,16 +1732,37 @@
;; incompleted))
(min-incompleted-ids (map car incompleted)) ;; do 'em all
(all-ids (append min-incompleted-ids (map car oldlaunched))))
(if (> (length all-ids) 0)
(begin
+ ;; (launch:is-test-alive "localhost" 435)
(debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as DEAD")
(for-each
- (lambda (test-id)
- (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))
- ;;(db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828
- all-ids))))))))
+ (lambda (test-id)
+ (let* (;; (run-dir (db:test-get-rundir-from-test-id dbstruct run-id test-id))
+ (tinfo (db:get-test-info-by-id dbstruct run-id test-id))
+ (run-dir (db:test-get-rundir tinfo))
+ (host (db:test-get-host tinfo))
+ (pid (db:test-get-process_id tinfo))
+ (result (db:get-status-from-final-status-file run-dir)))
+ (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result)))
+ (begin
+ (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
+ (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "PASS"
+ "Test stopped responding but it has PASSED; marking it PASS in the DB."))
+ (let ((is-alive (launch:is-test-alive host pid)))
+ (if is-alive
+ (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host " has a process on pid " pid ", NOT setting to DEAD.")
+ (begin
+ (debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result)
+ (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD"
+ "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
+ all-ids)
+ ;;call end of eud of run detection for posthook
+ (launch:end-of-run-check run-id)
+ )))))))
+
;; ALL REPLACED BY THE BLOCK ABOVE
;;
;; (sqlite3:execute
;; db
@@ -2026,10 +2071,14 @@
db
"SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
+;; extract index number given a header/data structure
+(define (db:get-index-by-header header field)
+ (list-index (lambda (x)(equal? x field)) header))
+
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(if (or (null? header) (not row))
#f
(let loop ((hed (car header))
@@ -2212,11 +2261,11 @@
(fprintf out "#,(simple-run ~S ~S ~S ~S)"
(simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))
;; simple get-runs
;;
-(define (db:simple-get-runs dbstruct runpatt count offset target)
+(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
(let* ((res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(targstr (string-intersperse keys "||'/'||"))
@@ -2223,17 +2272,22 @@
(keystr (conc targstr " AS target,"
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
" AND target LIKE '" target "'"
- " AND state != 'deleted' ORDER BY event_time DESC "
+ " AND state != 'deleted' "
+ (if (number? last-update)
+ (conc " AND last_update >= " last-update)
+ "")
+ " ORDER BY event_time DESC "
(if (number? count)
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
- ""))))
+ "")))
+ )
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (target id runname state status owner event_time)
@@ -2826,11 +2880,11 @@
(vector-ref inrec 5) ;; status
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
-(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
(let* ((res '())
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
@@ -2842,10 +2896,30 @@
(set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
db
qry
run-id)))
res))
+
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
+ (let* ((res '())
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
+ " AND last_update > ? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+ )))
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:fold-row
+ (lambda (res id testname item-path state status event-time run-duration)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res))
+ '()
+ db
+ qry
+ run-id
+ (or last-update 0))))))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
(db:with-db dbstruct run-id #f
(lambda (db)
ADDED dbmod.scm
Index: dbmod.scm
==================================================================
--- /dev/null
+++ dbmod.scm
@@ -0,0 +1,39 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; 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 .
+
+;;======================================================================
+
+(declare (unit dbmod))
+
+(module dbmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+
+(define (just-testing)
+ (print "JUST TESTING"))
+
+;; (define (debug:print . params) #f)
+;; (define (debug:print-info . params) #f)
+;;
+;; (define (set-functions dbgp dbgpinfo)
+;; (set! debug:print dbgp)
+;; (set! debug:print-info dbgpinfo))
+
+)
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -21,11 +21,11 @@
(declare (uses rmt))
(include "common_records.scm")
(use matchable)
(use fmt)
-(use ducttape-lib)
+(import ducttape-lib)
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
(for-each
Index: docs/manual/howto.txt
==================================================================
--- docs/manual/howto.txt
+++ docs/manual/howto.txt
@@ -13,196 +13,213 @@
// You should have received a copy of the GNU General Public License
// along with Megatest. If not, see .
//
// Copyright 2006-2012, Matthew Welland.
-How To Do Things
-----------------
-
-Process Runs
-~~~~~~~~~~~~
-
-Remove Runs
-^^^^^^^^^^^
-
-From the dashboard click on the button (PASS/FAIL...) for one of the tests. From the test control panel that
-comes up push the clean test button. The command field will be prefilled with a template command for removing
-that test. You can edit the command, for example change the argument to -testpatt to "%" to remove all tests.
-
-.Remove the test diskperf and all it's items
-----------------
-megatest -remove-runs -target ubuntu/nfs/none -runname ww28.1a -testpatt diskperf/% -v
-----------------
-
-.Remove all tests for all runs and all targets
-----------------
-megatest -remove-runs -target %/%/% -runname % -testpatt % -v
-----------------
-
-Archive Runs
-^^^^^^^^^^^^
-
-Megatest supports using the bup backup tool (https://bup.github.io/) to archive your tests for efficient storage
-and retrieval. Archived data can be rapidly retrieved if needed. The metadata for the run (PASS/FAIL status, run
-durations, time stamps etc.) are all preserved in the megatest database.
-
-For setup information see the Archiving topic in the reference section of this manual.
-
-To Archive
-++++++++++
-
-Hint: use the test control panel to create a template command by pushing the "Archive Tests" button.
-
-.Archive a full run
-----------------
-megatest -target ubuntu/nfs/none -runname ww28.1a -archive save-remove -testpatt %
-----------------
-
-To Restore
-++++++++++
-
-.Retrieve a single test
-----------------
-megatest -target ubuntu/nfs/none -runname ww28.1a -archive restore -testpatt diskperf/%
-----------------
-
-Hint: You can browse the archive using bup commands directly.
-
-----------------
-bup -d /path/to/bup/archive ftp
-----------------
-
-Submit jobs to Host Types based on Test Name
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-.In megatest.config
-------------------------
-[host-types]
-general ssh #{getbgesthost general}
-nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
-
-[hosts]
-general cubian xena
-
-[launchers]
-envsetup general
-xor/%/n 4C16G
-% nbgeneral
-
-[jobtools]
-launcher bsub
-# if defined and not "no" flexi-launcher will bypass launcher unless there is no
-# match.
-flexi-launcher yes
-------------------------
-
-Tricks
-------
-
-This section is a compendium of a various useful tricks for debugging,
-configuring and generally getting the most out of Megatest.
-
-Limiting your running jobs
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.
-
-In your testconfig:
-
-----------------
-[test_meta]
-jobgroup group1
-----------------
-
-In your megatest.config:
-
----------------
-[jobgroups]
-group1 10
-custdes 4
----------------
-
-Debugging Tricks
-----------------
-
-Examining The Environment
-~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Test Control Panel - xterm
-^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-From the dashboard click on a test PASS/FAIL button. This brings up a test control panel. Aproximately near the center left of the
-window there is a button "Start Xterm". Push this to get an xterm with the full context and environment loaded for that test. You can run
-scripts or ezsteps by copying from the testconfig (hint, load up the testconfig in a separate gvim or emacs window). This is the easiest way
-to debug your tests.
-
-During Config File Processing
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-It is often helpful to know the content of variables in various
-contexts as Megatest does the actions needed to run your tests. A handy technique is to force the startup of an xterm in the context being examined.
-
-For example, if an item list is not being generated as expected you
-can inject the startup of an xterm as if it were an item:
-
-.Original items table
------------------
-[items]
-CELLNAME [system getcellname.sh]
------------------
-
-.Items table modified for debug
------------------
-[items]
-DEBUG [system xterm]
-CELLNAME [system getcellnames.sh]
------------------
-
-When this test is run an xterm will pop up. In that xterm the
-environment is exactly that in which the script "getcellnames.sh"
-would run. You can now debug the script to find out why it isn't
-working as expected.
-
-Organising Your Tests and Tasks
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-The default location "tests" for storing tests can be extended by
-adding to your tests-paths section.
-
-----------------------------
-[misc]
-parent #{shell dirname $(readlink -f .)}
-
-[tests-paths]
-1 #{get misc parent}/simplerun/tests
-----------------------------
-
-The above example shows how you can use addition sections in your
-config file to do complex processing. By putting results of relatively
-slow operations into variables the processing of your configs can be
-kept fast.
-
-Alternative Method for Running your Job Script
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-.Directly running job in testconfig
--------------------
-[setup]
-runscript main.csh
--------------------
-
-The runscript method is essentially a brute force way to run scripts where the
-user is responsible for setting STATE and STATUS and managing the details of running a test.
-
-Debugging Server Problems
-~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Some handy Unix commands to track down issues with servers not
-communicating with your test manager processes. Please put in tickets
-at https://www.kiatoa.com/fossils/megatest if you have problems with
-servers getting stuck.
-
-----------------
-sudo lsof -i
-sudo netstat -lptu
-sudo netstat -tulpn
+How To Do Things
+----------------
+
+Process Runs
+~~~~~~~~~~~~
+
+Remove Runs
+^^^^^^^^^^^
+
+From the dashboard click on the button (PASS/FAIL...) for one of the tests. From the test control panel that
+comes up push the clean test button. The command field will be prefilled with a template command for removing
+that test. You can edit the command, for example change the argument to -testpatt to "%" to remove all tests.
+
+.Remove the test diskperf and all it's items
+----------------
+megatest -remove-runs -target ubuntu/nfs/none -runname ww28.1a -testpatt diskperf/% -v
+----------------
+
+.Remove all tests for all runs and all targets
+----------------
+megatest -remove-runs -target %/%/% -runname % -testpatt % -v
+----------------
+
+Archive Runs
+^^^^^^^^^^^^
+
+Megatest supports using the bup backup tool (https://bup.github.io/) to archive your tests for efficient storage
+and retrieval. Archived data can be rapidly retrieved if needed. The metadata for the run (PASS/FAIL status, run
+durations, time stamps etc.) are all preserved in the megatest database.
+
+For setup information see the Archiving topic in the reference section of this manual.
+
+To Archive
+++++++++++
+
+Hint: use the test control panel to create a template command by pushing the "Archive Tests" button.
+
+.Archive a full run
+----------------
+megatest -target ubuntu/nfs/none -runname ww28.1a -archive save-remove -testpatt %
+----------------
+
+To Restore
+++++++++++
+
+.Retrieve a single test
+----------------
+megatest -target ubuntu/nfs/none -runname ww28.1a -archive restore -testpatt diskperf/%
+----------------
+
+Hint: You can browse the archive using bup commands directly.
+
+----------------
+bup -d /path/to/bup/archive ftp
+----------------
+
+Pass Data from Test to Test
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+.To save the data call archive save within your test:
+----------------
+megatest -archive save
+----------------
+
+.To retrieve the data call archive get using patterns as needed
+----------------
+# Put the retrieved data into /tmp
+DESTPATH=/tmp/$USER/$MT_TARGET/$MT_RUN_NAME/$MT_TESTNAME/$MT_ITEMPATH/my_data
+mkdir -p $DESTPATH
+megatest -archive get -runname % -dest $DESTPATH
+----------------
+
+
+Submit jobs to Host Types based on Test Name
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+.In megatest.config
+------------------------
+[host-types]
+general ssh #{getbgesthost general}
+nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
+
+[hosts]
+general cubian xena
+
+[launchers]
+envsetup general
+xor/%/n 4C16G
+% nbgeneral
+
+[jobtools]
+launcher bsub
+# if defined and not "no" flexi-launcher will bypass launcher unless there is no
+# match.
+flexi-launcher yes
+------------------------
+
+Tricks
+------
+
+This section is a compendium of a various useful tricks for debugging,
+configuring and generally getting the most out of Megatest.
+
+Limiting your running jobs
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.
+
+In your testconfig:
+
+----------------
+[test_meta]
+jobgroup group1
+----------------
+
+In your megatest.config:
+
+---------------
+[jobgroups]
+group1 10
+custdes 4
+---------------
+
+Debugging Tricks
+----------------
+
+Examining The Environment
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Test Control Panel - xterm
+^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+From the dashboard click on a test PASS/FAIL button. This brings up a test control panel. Aproximately near the center left of the
+window there is a button "Start Xterm". Push this to get an xterm with the full context and environment loaded for that test. You can run
+scripts or ezsteps by copying from the testconfig (hint, load up the testconfig in a separate gvim or emacs window). This is the easiest way
+to debug your tests.
+
+During Config File Processing
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+It is often helpful to know the content of variables in various
+contexts as Megatest does the actions needed to run your tests. A handy technique is to force the startup of an xterm in the context being examined.
+
+For example, if an item list is not being generated as expected you
+can inject the startup of an xterm as if it were an item:
+
+.Original items table
+-----------------
+[items]
+CELLNAME [system getcellname.sh]
+-----------------
+
+.Items table modified for debug
+-----------------
+[items]
+DEBUG [system xterm]
+CELLNAME [system getcellnames.sh]
+-----------------
+
+When this test is run an xterm will pop up. In that xterm the
+environment is exactly that in which the script "getcellnames.sh"
+would run. You can now debug the script to find out why it isn't
+working as expected.
+
+Organising Your Tests and Tasks
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The default location "tests" for storing tests can be extended by
+adding to your tests-paths section.
+
+----------------------------
+[misc]
+parent #{shell dirname $(readlink -f .)}
+
+[tests-paths]
+1 #{get misc parent}/simplerun/tests
+----------------------------
+
+The above example shows how you can use addition sections in your
+config file to do complex processing. By putting results of relatively
+slow operations into variables the processing of your configs can be
+kept fast.
+
+Alternative Method for Running your Job Script
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+.Directly running job in testconfig
+-------------------
+[setup]
+runscript main.csh
+-------------------
+
+The runscript method is essentially a brute force way to run scripts where the
+user is responsible for setting STATE and STATUS and managing the details of running a test.
+
+Debugging Server Problems
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Some handy Unix commands to track down issues with servers not
+communicating with your test manager processes. Please put in tickets
+at https://www.kiatoa.com/fossils/megatest if you have problems with
+servers getting stuck.
+
+----------------
+sudo lsof -i
+sudo netstat -lptu
+sudo netstat -tulpn
----------------
Index: docs/manual/installation.txt
==================================================================
--- docs/manual/installation.txt
+++ docs/manual/installation.txt
@@ -20,9 +20,32 @@
Dependencies
~~~~~~~~~~~~
Chicken scheme and a number of "eggs" are required for building
-Megatest. See the script installall.sh in the utils directory of the
-source distribution for an automated way to install everything
-needed for building Megatest on Linux.
+Megatest. In the v1.66 and beyond assistance to create the build
+system is built into the Makefile.
+
+.Installation steps (overview)
+-------------------------------------
+./configure
+make chicken
+setup.sh make -j install
+-------------------------------------
+
+Or install the needed build system manually:
+
+. Chicken scheme from http://call-cc.org
+. IUP from http://webserver2.tecgraf.puc-rio.br/iup/
+. CD from http://webserver2.tecgraf.puc-rio.br/cd/
+. IM from https://webserver2.tecgraf.puc-rio.br/im/
+. ffcall from http://webserver2.tecgraf.puc-rio.br/iup/
+. Nanomsg from https://nanomsg.org/ (NOTE: Plan is to eliminate nanomsg dependency).
+. Needed eggs (look at the eggs lists in the Makefile)
+
+Then follow these steps:
+.Installation steps (self-built chicken scheme build system)
+-------------------------------------
+./configure
+make -j install
+-------------------------------------
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
-
+
The Megatest Users Manual