Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,14 +1,16 @@ # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' +# rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less + 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 nmsg-transport.scm filedb.scm \ + http-transport.scm filedb.scm \ client.scm synchash.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ portlogger.scm archive.scm env.scm @@ -33,10 +35,12 @@ # ARCHSTR=$(shell uname -m)_$(shell uname -r) # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") + +PNGFILES = $(shell cd docs/manual;ls *png) all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest @@ -45,12 +49,20 @@ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) - csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard +# install documentation to $(PREFIX)/docs +# DOES NOT REBUILD DOCS +# +$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html + mkdir -p $(PREFIX)/share/docs + $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html + for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done + +#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 @@ -63,11 +75,11 @@ runs.o : test_records.scm megatest.o : megatest-fossil-hash.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 rpc-transport.scm common_records.scm : altdb.scm 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 megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new @@ -89,16 +101,16 @@ $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard -$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard - $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard +#$(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 +# $(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 $@ @@ -119,10 +131,14 @@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ @@ -136,25 +152,28 @@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ -deploytarg/nbfind : utils/nbfind +deploytarg/viewscreen : utils/viewscreen $(INSTALL) $< $@ chmod a+x $@ +deploytarg/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) 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/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/bin/newdashboard $(PREFIX)/bin/mdboard + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm @@ -192,11 +211,11 @@ # 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/nbfind deploytarg/apropos.so +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake 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 @@ -257,7 +276,7 @@ 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 daemon.o dashboard-tests.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 nmsg-transport.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 daemon.o dashboard-tests.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 nmsg-transport.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 +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.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 daemon.o dashboard-tests.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 ADDED Makefile.deploy Index: Makefile.deploy ================================================================== --- /dev/null +++ Makefile.deploy @@ -0,0 +1,341 @@ +# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' +PREFIX=$(PWD) +CSCOPTS= -deploy +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 \ + client.scm synchash.scm daemon.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm tdb.scm rpc-transport.scm \ + portlogger.scm archive.scm env.scm + +# Eggs to install (straightforward ones) +EGGS=crypt 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-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm + +OFILES = $(SRCFILES:%.scm=%.o) +GOFILES = $(GUISRCF:%.scm=%.o) + +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}') + +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 lsb_release -sr) +# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") + +PNGFILES = $(shell cd docs/manual;ls *png) + +ARCHSIZE=64_ +IMVER=3.11 +IUPVER=3.17 +KTYPE=26g4 +CDVER=5.10 + +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard eggs sqlite matt iup + +mtest: $(OFILES) readline-fix.scm megatest.o + mkdir -p $(PREFIX)/deploy + csc $(CSCOPTS) $(OFILES) megatest.o -o $(PREFIX)/deploy/mtest + +eggs: $(PREFIX)/deploy/mtest/fmt.so + +$(PREFIX)/deploy/mtest/fmt.so: + chicken-install -deploy -p $(PREFIX)/deploy/mtest base64 format regex-case simple-exceptions typed-records apropos directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables csv typed-records pathname-expand json crypt dot-locking csv-xml z3 sql-de-lite hostinfo rpc directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables rpc fmt + +sqlite: $(PREFIX)/deploy/mtest/sqlite3.so + +$(PREFIX)/deploy/mtest/sqlite3.so: + wget http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz + tar xfz sqlite-autoconf-3090200.tar.gz + cd sqlite-autoconf-3090200 + cd sqlite-autoconf-3090200 && ./configure --prefix=`realpath $(PREFIX)/deploy/mtest` + cd sqlite-autoconf-3090200 && make + cd sqlite-autoconf-3090200 && make install + CSC_OPTIONS='-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/' chicken-install -deploy -p $(PREFIX)/deploy/mtest sqlite3 + +matt: $(PREFIX)/deploy/mtest/stml.so + +$(PREFIX)/deploy/mtest/stml.so: + wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' + tar -xzf stml.tar.gz + cd stml && cp install.cfg.template install.cfg + cd stml && echo "TARGDIR=`realpath $(PREFIX)/deploy/mtest`" > install.cfg + cd stml && echo "LOGDIR=/tmp/stmlrun" >> install.cfg + cd stml && echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg + cd stml && cp requirements.scm.template requirements.scm + cd stml && make clean + -cd stml && CSCOPTS="-C -fPIC" make + cd stml && chicken-install -deploy -p $(PREFIX)/deploy/mtest + wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' + tar -xzf opensrc.tar.gz + cd opensrc/mutils && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/dbi && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/margs && chicken-install -deploy -p $(PREFIX)/deploy/mtest + +iup: $(PREFIX)/deploy/mtest/iup.so + +$(PREFIX)/deploy/mtest/iup.so: + wget -c http://www.kiatoa.com/matt/chicken-build/cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + tar -xzvf cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + cp $(PREFIX)/deploy/mtest/ftgl/lib/*/* $(PREFIX)/deploy/mtest/ + wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + tar -xzf ffcall.tar.gz + cd ffcall && ./configure --prefix=`realpath $(PREFIX)/deploy/mtest/` --enable-shared + cd ffcall && make CC="gcc -fPIC" + cd ffcall && make install + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks -feature disable-iup-web iup + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks canvas-draw + +dboard: $(OFILES) $(GOFILES) dashboard.scm + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o $(PREFIX)/deploy/mtest/dboard2 + cp $(PREFIX)/deploy/mtest/dboard2/dboard2 $(PREFIX)/deploy/mtest/dboard + +ndboard : newdashboard.scm $(OFILES) $(GOFILES) + csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o $(PREFIX)/deploy/mtest/newdboard + +# install documentation to $(PREFIX)/docs +# DOES NOT REBUILD DOCS +# +$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html + mkdir -p $(PREFIX)/share/docs + $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html + for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done + +#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-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-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 +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 rpc-transport.scm +common_records.scm : altdb.scm +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 + +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 + csc $(CSCOPTS) -c $< + +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper + @echo Installing to PREFIX=$(PREFIX) + $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest + 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/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper + utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard + chmod a+x $(PREFIX)/bin/newdashboard + +#$(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 + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_ezstep : utils/mt_ezstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_xterm : utils/mt_xterm + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/loadrunner : utils/loadrunner + $(INSTALL) $< $@ + chmod a+x $@ + +# $(PREFIX)/bin/refdb : refdb +# $(INSTALL) $< $@ +# chmod a+x $@ + +deploytarg/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +# install dashboard as dboard so wrapper script can be called dashboard +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) 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/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html + +$(PREFIX)/bin/.$(ARCHSTR) : + mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + +test: tests/tests.scm + cd tests;csi -I .. -b -n tests.scm + +ext-tests/.fslckout : $(MTQA_FOSSIL) + mkdir -p ext-tests + cd ext-tests;fossil open --nested $(MTQA_FOSSIL) + +$(MTQA_FOSSIL) : + fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) + +clean : + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm + +#====================================================================== +# Make the records files +#====================================================================== + +# vg_records.scm : records.sh +# ./records.sh + +#====================================================================== +# Deploy section (not complete yet) +#====================================================================== + +$(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/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 + +sd : datashare-testing/sd + mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath + +xterm : sd + (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) + +datashare-testing/spublish : spublish.scm $(OFILES) + csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish + +datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o + csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +sretrieve/sretrieve : datashare-testing/sretrieve + csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o + chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ + srfi-1 posix regex regex-case srfi-69 + +# 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;\ + fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + 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 daemon.o dashboard-tests.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 daemon.o dashboard-tests.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 Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -107,11 +107,11 @@ (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -12,14 +12,14 @@ ;; C L I E N T S ;;====================================================================== (require-extension (srfi 18) extras tcp s11n) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) ;; (use zmq) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) @@ -41,208 +41,75 @@ (define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) -(define (client:connect iface port) - (case (server:get-transport) - ((rpc) (rpc:client-connect iface port)) - ((http) (http:client-connect iface port)) - ((zmq) (zmq:client-connect iface port)) - (else (rpc:client-connect iface port)))) - -(define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) - (case (server:get-transport) - ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http run-id)) - (else (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id)))) - -;; (define (client:login-no-auto-setup server-info run-id) -;; (case (server:get-transport) -;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) -;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) -;; (else (rpc:login-no-auto-client-setup server-info run-id)))) -;; -;; (define (client:setup-rpc run-id) -;; (debug:print 0 *default-log-port* "INFO: client:setup remaining-tries=" remaining-tries) -;; (if (<= remaining-tries 0) -;; (begin -;; (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id) -;; (exit 1)) -;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) -;; (debug:print-info 0 *default-log-port* "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) -;; (if host-info -;; (let* ((iface (car host-info)) -;; (port (cadr host-info)) -;; (start-res (client:connect iface port)) -;; ;; (ping-res (server:ping-server run-id iface port)) -;; (ping-res (client:login-no-auto-setup start-res run-id))) -;; (if ping-res ;; sucessful login? -;; (begin -;; (hash-table-set! *runremote* run-id start-res) -;; start-res) ;; return the server info -;; (if (member remaining-tries '(3 4 6)) -;; (begin ;; login failed -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) -;; (hash-table-delete! *runremote* run-id) -;; (open-run-close tasks:server-force-clean-run-record -;; tasks:open-db -;; run-id -;; (car host-info) -;; (cadr host-info) -;; " client:setup (host-info=#t)") -;; (thread-sleep! 5) -;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) -;; (begin -;; (debug:print 25 *default-log-port* "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) -;; (thread-sleep! 5) -;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) -;; ;; YUK: rename server-dat here -;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) -;; (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) -;; (if server-dat -;; (let* ((iface (tasks:hostinfo-get-interface server-dat)) -;; (port (tasks:hostinfo-get-port server-dat)) -;; (start-res (http-transport:client-connect iface port)) -;; ;; (ping-res (server:ping-server run-id iface port)) -;; (ping-res (rmt:login-no-auto-client-setup start-res run-id))) -;; (if start-res -;; (begin -;; (hash-table-set! *runremote* run-id start-res) -;; start-res) -;; (if (member remaining-tries '(2 5)) -;; (begin ;; login failed -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) -;; (hash-table-delete! *runremote* run-id) -;; (open-run-close tasks:server-force-clean-run-record -;; tasks:open-db -;; run-id -;; (tasks:hostinfo-get-interface server-dat) -;; (tasks:hostinfo-get-port server-dat) -;; " client:setup (server-dat = #t)") -;; (thread-sleep! 2) -;; (server:try-running run-id) -;; (thread-sleep! 10) ;; give server a little time to start up -;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) -;; (begin -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) -;; (thread-sleep! 5) -;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) -;; (begin ;; no server registered -;; (if (eq? remaining-tries 2) -;; (begin -;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") -;; (client:setup run-id remaining-tries: 10)) -;; (begin -;; (thread-sleep! 2) -;; (debug:print 25 *default-log-port* "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) -;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) -;; (begin -;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") -;; (server:try-running run-id))) -;; (thread-sleep! 10) ;; give server a little time to start up -;; (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) - -;; Do all the connection work, look up the transport type and set up the -;; connection if required. -;; -;; There are two scenarios. -;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline -;; 2. We are a run tests, list runs or other interactive process and we must figure out -;; *transport-type* and *runremote* from the monitor.db -;; -;; client:setup -;; -;; lookup_server, need to remove *runremote* stuff -;; -(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) - (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) - (let* ((tdbdat (tasks:open-db))) - (if (<= remaining-tries 0) - (begin - (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id) - (exit 1)) - (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) - (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if server-dat - (let* ((iface (tasks:hostinfo-get-interface server-dat)) - (hostname (tasks:hostinfo-get-hostname server-dat)) - (port (tasks:hostinfo-get-port server-dat)) - (start-res (case *transport-type* - ((http)(http-transport:client-connect iface port)) - ((nmsg)(nmsg-transport:client-connect hostname port)))) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res run-id)) - ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id))) - (if logininfo - (car (vector-ref logininfo 1)) - #f)))))) - (if (and start-res - ping-res) - (begin - (hash-table-set! *runremote* run-id start-res) - (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) - start-res) - (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) - (case *transport-type* - ((http)(http-transport:close-connections run-id))) - (hash-table-delete! *runremote* run-id) - (tasks:kill-server-run-id run-id) - (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) - run-id - (tasks:hostinfo-get-interface server-dat) - (tasks:hostinfo-get-port server-dat) - " client:setup (server-dat = #t)") - (if (> remaining-tries 8) - (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little - (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time - (server:try-running run-id) - (thread-sleep! 5) ;; give server a little time to start up - (client:setup run-id remaining-tries: (- remaining-tries 1)) - ))) - (begin ;; no server registered - (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) - (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) - (if (< num-available 2) - (server:try-running run-id)) - (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) - -;; keep this as a function to ease future -(define (client:start run-id server-info) - (http-transport:client-connect (tasks:hostinfo-get-interface server-info) - (tasks:hostinfo-get-port server-info))) - -;; ;; client:signal-handler -;; (define (client:signal-handler signum) -;; (signal-mask! signum) -;; (set! *time-to-exit* #t) -;; (handle-exceptions -;; exn -;; (debug:print 0 *default-log-port* " ... exiting ...") -;; (let ((th1 (make-thread (lambda () -;; "") ;; do nothing for now (was flush out last call if applicable) -;; "eat response")) -;; (th2 (make-thread (lambda () -;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") -;; (thread-sleep! 1) ;; give the flush one second to do it's stuff -;; (debug:print 0 *default-log-port* " Done.") -;; (exit 4)) -;; "exit on ^C timer"))) -;; (thread-start! th2) -;; (thread-start! th1) -;; (thread-join! th2)))) -;; -;; ;; client:launch -;; ;; Need to set the signal handler somewhere other than here as this -;; ;; routine will go away. -;; ;; -;; (define (client:launch run-id) -;; (set-signal-handler! signal/int client:signal-handler) -;; (set-signal-handler! signal/term client:signal-handler) -;; (if (client:setup run-id) -;; (debug:print-info 2 *default-log-port* "connected as client") -;; (begin -;; (debug:print-error 0 *default-log-port* "Failed to connect as client") -;; (exit)))) -;; +;; BB: commenting out orphan code +;;;;; +;; (define (client:connect iface port) +;; (case (server:get-transport) +;; ((rpc) (rpc:client-connect iface port)) +;; ((http) (http:client-connect iface port)) +;; ((zmq) (zmq:client-connect iface port)) +;; (else (rpc:client-connect iface port)))) + +(define (client:setup run-id #!key (remaining-tries 10)) + ;;(BB> "Entered client:setup with run-id="run-id" and remaining-tries="remaining-tries) + + (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) + (let* ((server-dat (tasks:bb-get-server-info run-id)) + (transport (if (and server-dat (vector? server-dat)) (string->symbol (tasks:hostinfo-get-transport server-dat)) 'noserver))) + + (case transport + ((noserver) ;; no server registered + (BB> "noserver") + (if (<= remaining-tries 0) + (begin + (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id) + (exit 1)) + (begin + (let ((num-available (tasks:bb-num-in-available-state run-id))) + (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + (if (< num-available 2) + (server:try-running run-id)) + (thread-sleep! (+ 2 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. + (client:setup run-id remaining-tries: (- remaining-tries 1)))))) + ((http) (client:setup-http run-id server-dat remaining-tries)) + ((rpc) (rpc-transport:client-setup run-id server-dat remtries: remaining-tries)) + (else + (debug:print-error 0 *default-log-port* "(6) Transport [" + transport "] specified for run-id [" run-id "] is not implemented in client:setup. Cannot proceed.") + (exit 1))))) + + +;; client:setup-http +;; +;; For http transport, robustly ensure an advertised-running server is actually working and responding, and +;; establish tcp connection to server. For servers marked running but not responding, kill them and clear from mdb +;; +(define (client:setup-http run-id server-dat remaining-tries) + (let* ((iface (tasks:hostinfo-get-interface server-dat)) + (hostname (tasks:hostinfo-get-hostname server-dat)) + (port (tasks:hostinfo-get-port server-dat)) + + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if (and start-res ping-res) + (begin + (rmt:set-cinfo run-id start-res) ;; (hash-table-set! *runremote* run-id start-res) ;; side-effect - *runremote* cache init fpr rmt:* + (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) + start-res) + (begin ;; login failed but have a server record, clean out the record and try again + (debug:print-info 0 *default-log-port* "client:setup-http, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (http-transport:close-connections run-id) + (rmt:del-cinfo run-id) ;; (hash-table-delete! *runremote* run-id) ;; BB: suspect there is nothing to delete ... + (tasks:kill-server-run-id run-id) ;; -9 so the hung processes dont eat 100% when not responding to sigterm. + (tasks:bb-server-force-clean-run-record run-id iface port + " client:setup-http (server-dat = #t)") + (if (> remaining-tries 8) + (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little + (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time + (server:try-running run-id) + (thread-sleep! 5) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1)) + )))) + Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 nanomsg sql-de-lite hostinfo) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo typed-records) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -42,10 +42,32 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES + +(define *contexts* (make-hash-table)) + +;; Common data structure for +(defstruct cxt + (taskdb #f) + (cmutex (make-mutex))) + +;; safe method for accessing a context given a toppath +;; +(define (common:with-cxt toppath proc) + (mutex-lock! *context-mutex*) + (let ((cxt (hash-table-ref/default *contexts* toppath #f))) + (if (not cxt) + (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) + (let ((cxt-mutex (cxt-mutex cxt))) + (mutex-unlock! *context-mutex*) + (mutex-lock! cxt-mutex) + (let ((res (proc cxt))) + (mutex-unlock! cxt-mutex) + res)))) + (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data @@ -77,12 +99,15 @@ (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'http) -(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg + +;; default preference for transport-type is set here +;; +(define *transport-type* 'rpc) ;; override with [server] transport http|rpc + (define *runremote* (make-hash-table)) ;; if set up for server communication this will hold (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) @@ -114,10 +139,14 @@ ;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than ;; five seconds ago (define *pre-reqs-met-cache* (make-hash-table)) +;; cache of verbosity given string +;; +(define *verbosity-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -131,10 +160,12 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) +(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. + ;;====================================================================== ;; V E R S I O N ;;====================================================================== (define (common:get-full-version) @@ -143,21 +174,26 @@ (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;; from metadat lookup MEGATEST_VERSION ;; -(define (common:get-last-run-version) +(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB (rmt:get-var "MEGATEST_VERSION")) +(define (common:get-last-run-version-number) + (string->number + (substring (common:get-last-run-version) 0 6))) + (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) ;; Move me elsewhere ... +;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db) (db:multi-db-sync #f ;; do all run-ids ;; 'new2old @@ -167,15 +203,17 @@ ;; 'old2new 'new2old) (if (common:version-changed?) (common:set-last-run-version))) +;; Force a megatest cleanup-db if version is changed and skip-version-check not specified +;; (define (common:exit-on-version-changed) (if (common:version-changed?) (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))) (debug:print 0 *default-log-port* - "ERROR: Version mismatch!\n" + "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (if (and (file-exists? mtconf) (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db (begin @@ -353,18 +391,21 @@ (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" "testsuite" ) - (pathname-file *toppath*))) + (if *toppath* + (pathname-file *toppath*) + (pathname-file (current-directory))))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) (or (args:get-arg "-runtests") + (args:get-arg "-run") (args:get-arg "-server") ;; (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") ;; (args:get-arg "-get-run-status") )) @@ -484,10 +525,36 @@ ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) + +;; return first command that exists, else #f +;; +(define (common:which cmds) + (if (null? cmds) + #f + (let loop ((hed (car cmds)) + (tal (cdr cmds))) + (let ((res (with-input-from-pipe (conc "which " hed) read-line))) + (if (and (string? res) + (file-exists? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + +(define (common:get-install-area) + (let ((exe-path (car (argv)))) + (if (file-exists? exe-path) + (handle-exceptions + exn + #f + (pathname-directory + (pathname-directory + (pathname-directory exe-path)))) + #f))) ;;====================================================================== ;; 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 ;;====================================================================== @@ -587,10 +654,76 @@ (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) +;; get min or max, use > for max and < for min, this works around the limits on apply +;; +(define (common:min-max comp lst) + (if (null? lst) + #f ;; better than an exception for my needs + (fold (lambda (a b) + (if (comp a b) a b)) + (car lst) + lst))) + +;; path list to hash-table tree +;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) +;; +(define (common:list->htree lst) + (let ((resh (make-hash-table))) + (for-each + (lambda (inlst) + (let loop ((ht resh) + (hed (car inlst)) + (tal (cdr inlst))) + (if (hash-table-ref/default ht hed #f) + (if (not (null? tal)) + (loop (hash-table-ref ht hed) + (car tal) + (cdr tal))) + (begin + (hash-table-set! ht hed (make-hash-table)) + (loop ht hed tal))))) + lst) + resh)) + +;; hash-table tree to html list tree +;; +;; tipfunc takes two parameters: y the tip value and path the path to that point +;; +(define (common:htree->html ht path tipfunc) + (let ((datlist (sort (hash-table->alist ht) + (lambda (a b) + (string< (car a)(car b)))))) + (if (null? datlist) + (tipfunc #f path) ;; really shouldn't get here + (s:ul + (map (lambda (x) + (let* ((levelname (car x)) + (y (cdr x)) + (newpath (append path (list levelname))) + (leaf (or (not (hash-table? y)) + (null? (hash-table-keys y))))) + (if leaf + (s:li (tipfunc y newpath)) + (s:li + (list + levelname + (common:htree->html y newpath tipfunc)))))) + datlist))))) + +;; hash-table tree to alist tree +;; +(define (common:htree->atree ht) + (map (lambda (x) + (cons (car x) + (let ((y (cdr x))) + (if (hash-table? y) + (common:htree->atree y) + y)))) + (hash-table->alist ht))) ;;====================================================================== ;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== @@ -634,10 +767,18 @@ )))))) ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== + +;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 +;; +(define (common:lazy-modification-time fpath) + (handle-exceptions + exn + 0 + (file-modification-time fpath))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? @@ -658,12 +799,12 @@ (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) -(define (get-cpu-load) - (car (common:get-cpu-load))) +(define (get-cpu-load #!key (remote-host #f)) + (car (common:get-cpu-load remote-host))) ;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) ;; (cpu-load #f)) ;; (for-each (lambda (l) ;; (let ((match (string-search load-rx l))) @@ -674,16 +815,22 @@ ;; (car load-res)) ;; cpu-load)) ;; get cpu load by reading from /proc/loadavg, return all three values ;; -(define (common:get-cpu-load) - (with-input-from-file "/proc/loadavg" - (lambda ()(list (read)(read)(read))))) +(define (common:get-cpu-load remote-host) + (if remote-host + (map (lambda (res) + (if (eof-object? res) 9e99 res)) + (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)))))) -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)) - (let* ((loadavg (common:get-cpu-load)) +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) + (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload numcpus)) (loadjmp (- first next))) (cond @@ -696,26 +843,30 @@ (> count 0)) (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) -(define (common:get-num-cpus) - (with-input-from-file "/proc/cpuinfo" - (lambda () - (let loop ((numcpu 0) - (inl (read-line))) - (if (eof-object? inl) - numcpu - (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) - (+ numcpu 1) - numcpu) - (read-line))))))) +(define (common:get-num-cpus remote-host) + (let ((proc (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + numcpu + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line))))))) + (if remote-host + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/cpuinfo") + proc) + (with-input-from-file "/proc/cpuinfo" proc)))) ;; wait for normalized cpu load to drop below maxload ;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)) - (let ((num-cpus (common:get-num-cpus))) +(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) + (let ((num-cpus (common:get-num-cpus remote-host))) (common:wait-for-cpuload maxload num-cpus 15 msg: msg))) (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) @@ -918,16 +1069,20 @@ vars (lambda (var val) (setenv var val))) vars)) -(define (common:run-a-command cmd) - (let ((fullcmd (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)))) +(define (common:run-a-command cmd #!key (with-vars #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (common:without-vars fullcmd "MT_.*"))) + (if with-vars + (common:without-vars cmd) + (common:without-vars fullcmd "MT_.*")))) ;;====================================================================== ;; T I M E A N D D A T E ;;====================================================================== @@ -1057,10 +1212,18 @@ ;; ((RUNNING) "9 131 232") ;; ((KILLREQ) "39 82 206") ;; ((KILLED) "234 101 17") ;; ((NOT_STARTED) "240 240 240") ;; (else "192 192 192"))) + +(define (common:iup-color->rgb-hex instr) + (string-intersperse + (map (lambda (x) + (number->string x 16)) + (map string->number + (string-split instr))) + "/")) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") @@ -1086,22 +1249,10 @@ (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) -(define (common:open-nm-req addr) - (let* ((req (nn-socket 'req)) - (res (nn-connect req addr))) - req)) - -;; (with-output-to-string (lambda ()(serialize obj))) -(define (common:nm-send-receive soc msg) - (nn-send soc msg) - (nn-recv soc)) - -(define (common:close-nm-req soc) - (nn-close soc)) (define (common:send-dboard-main-changed) (let* ((dashboard-ips (mddb:get-dashboards))) (for-each (lambda (ipadr) @@ -1111,91 +1262,11 @@ (if (not res) ;; couldn't reach that dashboard - remove it from db (print "ERROR: couldn't reach dashboard " ipadr)) res)) dashboard-ips))) -(define (common:nm-send-receive-timeout req msg) - (let* ((key "ping") - (success #f) - (keepwaiting #t) - (result #f) - (sendrec (make-thread - (lambda () - (nn-send req msg) - (set! result (nn-recv req)) - (set! success #t)) - "send-receive")) - (timeout (make-thread (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (print "still waiting after count seconds...") - (if (and keepwaiting (< count 10)) - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for reply") - (thread-terminate! sendrec)))) - "timeout"))) - (handle-exceptions - exn - (begin - (print-call-chain) - (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn))) - (thread-start! timeout) - (thread-start! sendrec) - (thread-join! sendrec) - (if success (thread-terminate! timeout))) - result)) - -(define (common:ping-nm req) - ;; send a random number and check that we get it back - (let* ((key "ping") - (success #f) - (keepwaiting #t) - (ping (make-thread - (lambda () - (print "ping: sending string \"" key "\", expecting " (current-process-id)) - (nn-send req key) - (let ((result (nn-recv req))) - (if (equal? (conc (current-process-id)) result) - (begin - (print "ping, success: received \"" result "\"") - (set! success #t)) - (begin - (print "ping, failed: received key \"" result "\"") - (set! keepwaiting #f) - (set! success #f))))) - "ping")) - (timeout (make-thread (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (print "still waiting after count seconds...") - (if (and keepwaiting (< count 10)) - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for ping") - (thread-terminate! ping)))) - "timeout"))) - (handle-exceptions - exn - (begin - (print-call-chain) - (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) - (print "ping failed to connect to tcp://" hostport)) - (thread-start! timeout) - (thread-start! ping) - (thread-join! ping) - (if success (thread-terminate! timeout))) - (if return-socket - (if success req #f) - (begin - (nn-close req) - success)))) - + ;;====================================================================== ;; D A S H B O A R D D B ;;====================================================================== (define (mddb:open-db) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -44,23 +44,30 @@ (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; (define (debug:calc-verbosity vstr) - (cond - ((number? vstr) vstr) - ((not (string? vstr)) 1) - ;; ((string-match "^\\s*$" vstr) 1) - (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) - (cond - ((> (length debugvals) 1) debugvals) - ((> (length debugvals) 0)(car debugvals)) - (else 1)))) - ((args:get-arg "-v") 2) - ((args:get-arg "-q") 0) - (else 1))) + (or (hash-table-ref/default *verbosity-cache* vstr #f) + (let ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1)))) + (hash-table-set! *verbosity-cache* vstr res) + res))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) @@ -103,10 +110,24 @@ (lambda () (if *logging* (db:log-event (apply conc params)) (apply print params) ))))) + +;; Brandon's debug printer shortcut (indulge me :) +(define (BB> . in-args) + (let* ((stack (get-call-chain)) + (location #f)) + (for-each + (lambda (frame) + (let* ((this-loc (vector-ref frame 0)) + (this-func (cadr (string-split this-loc " ")))) + (if (equal? this-func "BB>") + (set! location this-loc)))) + stack) + (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args))) + (apply debug:print dp-args)))) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -41,15 +41,15 @@ (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) + (or cfg-ovrd default-override "viewscreen "))) ;; "xterm -geometry 180x20 -e \""))) (define (dtests:get-post-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (or cfg-ovrd default-override ""))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" @@ -414,11 +414,11 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test run-id test-id) ;; run-id run-key origtest) +(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") local: #t)) (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) @@ -628,15 +628,13 @@ " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) - (common:without-vars - (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)) - "MT_.*")))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -86,16 +86,23 @@ "-use-local" "-skip-version-check" ) args:arg-hash 0)) + +(if (not (null? remargs)) + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit))) (if (args:get-arg "-h") (begin (print help) (exit))) +;; TODO: Move this inside (main) +;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) @@ -109,10 +116,11 @@ updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs ) + (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 tabdats: (make-hash-table) @@ -121,37 +129,43 @@ updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f )) +;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) +;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (hash-table-ref/default (dboard:commondat-tabdats commondat) - (or tab-num (dboard:commondat-curr-tab-num commondat)) + (or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat #f)) +;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table +;; (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! (dboard:commondat-tabdats commondat) tabnum tabdat)) -;; gets and calls updater based on curr-tab-num +;; gets and calls updater list based on curr-tab-num +;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) - (for-each + (for-each ;; perform the function calls for the complete updaters list (lambda (updater) ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) @@ -200,23 +214,33 @@ (originx #f) (originy #f) ((layout-update-ok #t) : boolean) ((compact-layout #t) : boolean) + ;; Run times layout + ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere + (graph-matrix #f) + ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info + ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info + ((graph-matrix-row 1) : number) + ((graph-matrix-col 1) : number) + ;; Controls used to launch runs etc. ((command "") : string) ;; for run control this is the command being built up - (command-tb #f) + (command-tb #f) ;; widget for the type of command; run, remove-runs etc. + (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns (key-listboxes #f) (key-lbs #f) run-name ;; from run name setting widget states ;; states for -state s1,s2 ... statuses ;; statuses for -status s1,s2 ... ;; Selector variables curr-run-id ;; current row to display in Run summary view + prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard - ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab + ((filters-changed #t) : boolean) ;; to to indicate that the user changed filters for this tab ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters ((hide-empty-runs #f) : boolean) ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) ((searchpatts (make-hash-table)) : hash-table) ;; @@ -227,35 +251,44 @@ ;; db info to file the .db files for the area (dbdir #f) (dbfpath #f) (dbkeys #f) - ((last-db-update 0) : number) ;; last db file timestamp + ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp (monitor-db-path #f) ;; where to find monitor.db ro ;; is the database read-only? ;; tests data ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targests added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) - + ;; runs-summary tab state + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) + ((runs-summary-mode-buttons '()) : list) + ((runs-summary-mode 'one-run) : symbol) + ((runs-summary-mode-change-callbacks '()) : list) + (runs-summary-source-runname-label #f) + (runs-summary-dest-runname-label #f) + ;; runs summary view + tests-tree ;; used in newdashboard ) (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:tabdat-test-patts-use vec) - (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? ;; additional setters for dboard:data (define (dboard:tabdat-test-patts-set!-use vec val) (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) @@ -275,10 +308,18 @@ (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) + +;; RADT => Matrix defstruct addition +(defstruct dboard:graph-dat + ((id #f) : string) + ((color #f) : vector) + ((flag #t) : boolean) + ((cell #f) : number) + ) ;; data for runs, tests etc. was used in run summary? ;; (defstruct dboard:runsdat ;; new system @@ -316,55 +357,21 @@ run: run tests: (or tests (make-hash-table)) key-vals: key-vals )) -(define (dboard:rundat-copy-tests-to-by-name rundat) - (let ((src-ht (dboard:rundat-tests rundat)) - (trg-ht (dboard:rundat-tests-by-name rundat))) - (if (and (hash-table? src-ht)(hash-table? trg-ht)) - (begin - (hash-table-clear! trg-ht) - (for-each - (lambda (testdat) - (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) - (hash-table-values src-ht))) - (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) - (defstruct dboard:testdat id ;; testid state ;; test state status ;; test status ) -(define (dboard:runsdat-get-col-num dat target runname force-set) - (let* ((runs-index (dboard:runsdat-runs-index dat)) - (col-name (conc target "/" runname)) - (res (hash-table-ref/default runs-index col-name #f))) - (if res - res - (if force-set - (let ((max-col-num (+ 1 (apply max -1 (hash-table-values runs-index))))) - (hash-table-set! runs-index col-name max-col-num) - max-col-num))))) - -(define (dboard:runsdat-get-row-num dat testname itempath force-set) - (let* ((tests-index (dboard:runsdat-runs-index dat)) - (row-name (conc testname "/" itempath)) - (res (hash-table-ref/default runs-index row-name #f))) - (if res - res - (if force-set - (let ((max-row-num (+ 1 (apply max -1 (hash-table-values tests-index))))) - (hash-table-set! runs-index row-name max-row-num) - max-row-num))))) - ;; default is to NOT set the cell if the column and row names are not pre-existing ;; (define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) - (let* ((col-num (dboard:runsdat-get-col-num dat target runname force-set)) - (row-num (dboard:runsdat-get-row-num dat testname itempath force-set))) + (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) + (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) (if (and row-num col-num) (let ((tdat (dboard:testdat id: test-id state: state status: status))) @@ -472,13 +479,21 @@ ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((num-to-get 100) + (let* ((num-to-get + (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get"))) + (if num-tests-from-config + (begin + (BB> "override num-tests 100 -> "num-tests-from-config) + (string->number num-tests-from-config)) + 100))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) + (do-not-use-db-file-timestamps (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname @@ -487,19 +502,25 @@ (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) rd))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) - (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3)) + (last-update + (if do-not-use-query-timestamps + 0 + (dboard:rundat-last-update run-dat) + ;;(hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0) + )) + (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (tasks:get-task-db-path)) (db-pth (conc db-dir "/" run-id ".db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) - (tmptests (if (or (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") - (>= (file-modification-time db-path) last-update)) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + (tmptests (if (or do-not-use-db-file-timestamps + (>= (common:lazy-modification-time db-path) last-update)) + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order @@ -539,11 +560,14 @@ ;; set last-update to 0 if still getting data incrementally (if (> (dboard:rundat-run-data-offset run-dat) 0) (begin ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0") - (dboard:rundat-last-update-set! run-dat 0)) + ;; (dboard:rundat-last-update-set! run-dat 0) + (dboard:rundat-last-update-set! run-dat 0)) + ;; (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- start-time 3)) + (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured. ;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht)) tests-ht)) @@ -637,10 +661,13 @@ (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:update-tree tabdat runs-hash header tb))) + + + (define *collapsed* (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) @@ -790,19 +817,18 @@ (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0) (all-test-names (make-hash-table))) - ;; create a concise list of test names ;; (for-each (lambda (rundat) (if rundat (let* ((testdats (dboard:rundat-tests rundat)) (testnames (map test:test-get-fullname (hash-table-values testdats)))) - (dboard:rundat-copy-tests-to-by-name rundat) + (dcommon:rundat-copy-tests-to-by-name rundat) ;; for the normalized list of testnames (union of all runs) (if (not (and (dboard:tabdat-hide-empty-runs tabdat) (null? testnames))) (for-each (lambda (testname) (hash-table-set! all-test-names testname #t)) @@ -925,13 +951,14 @@ (define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) (set-bg-on-filter commondat tabdat)) +;; force ALL updates to zero (effectively) +;; (define (mark-for-update tabdat) - ;; (dboard:tabdat-filters-changed-set! tabdat #t) - (dboard:tabdat-last-db-update-set! tabdat 0)) + (dboard:tabdat-last-db-update-set! tabdat (make-hash-table))) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -1062,11 +1089,14 @@ ;; (define (dashboard:update-run-command tabdat) (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) (cmd (dboard:tabdat-command tabdat)) (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) - (if (equal? tp "") "%" tp))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (target (let ((targ-list (dboard:tabdat-target tabdat))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:tabdat-run-name tabdat)) @@ -1149,10 +1179,11 @@ ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) (db-target-dat (rmt:get-targets)) + (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") (make-list (length header) "na")) @@ -1164,13 +1195,20 @@ (map munge-target runconf-targs) ))) (for-each (lambda (target) - (tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name)) + (if (not (hash-table-ref/default runs-tree-ht target #f)) + ;; (let ((existing (tree:find-node tb target))) + ;; (if (not existing) + (begin + (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name)) + (hash-table-set! runs-tree-ht target #t)))) all-targets))) +;; Run controls panel +;; (define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) (test-names (hash-table-keys all-tests-registry)) @@ -1211,11 +1249,12 @@ (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) (tb (dboard:tabdat-runs-tree tabdat))) (dboard:commondat-add-updater commondat (lambda () - (dashboard:update-tree-selector tabdat)) + (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) + (dashboard:update-tree-selector tabdat))) tab-num: tab-num) result))) ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs @@ -1223,34 +1262,53 @@ ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) (define (dboard:runs-tree-browser commondat tabdat) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #: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) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-view-changed-set! tabdat #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) - ))) + (let* ((txtbox (iup:textbox #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + (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 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #: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) "/")) + (dashboard:update-run-command tabdat) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-view-changed-set! tabdat #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:tabdat-runs-tree-set! tabdat tb) - tb)) + (iup:vbox tb txtbox))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -1311,10 +1369,13 @@ ) "text-list-toggle-box")))) (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) (dcommon:command-testname-selector commondat tabdat update-keyvals)) (iup:vbox + (iup:split + #:orientation "HORIZONTAL" + #:value 800 (let* ((cnv-obj (iup:canvas ;; #:size "500x400" #:expand "YES" #:scrollbar "YES" #:posx "0.5" @@ -1351,11 +1412,61 @@ (if (> step 0) (* scalex 0.02) (* scalex -0.02)))))) "wheel-cb")) ))) - cnv-obj))))) + cnv-obj) + (let* ((hb1 (iup:hbox)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (changed #f) + (graph-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:scrollbar "YES" + #:numcol 10 + #:numlin 20 + #:numcol-visible (min 8) + #:numlin-visible 1 + #:click-cb + (lambda (obj row col status) + (let* + ((graph-cell (conc row ":" col)) + (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (dboard:graph-dat-flag-set! graph-dat #f) + (dboard:graph-dat-flag-set! graph-dat #t)) + (if (not (dboard:tabdat-running-layout tabdat)) + (begin + (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (dboard:tabdat-last-data-update-set! tabdat (current-seconds)) + (thread-start! (make-thread + (lambda () + (dboard:tabdat-running-layout-set! tabdat #t) + (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + (dboard:tabdat-running-layout-set! tabdat #f)) + "run-times-tab-layout-updater")))) + ;;(dboard:tabdat-view-changed-set! tabdat #t) + ))))) + (dboard:tabdat-graph-matrix-set! tabdat graph-matrix) + (iup:attribute-set! graph-matrix "WIDTH0" 0) + (iup:attribute-set! graph-matrix "HEIGHT0" 0) + graph-matrix)) + (iup:hbox + (iup:vbox + (iup:button "Show All" #:action (lambda (obj) + (for-each (lambda (graph-cell) + (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) + (dboard:graph-dat-flag-set! graph-dat #t))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))) + (iup:hbox + (iup:button "Hide All" #:action (lambda (obj) + (for-each (lambda (graph-cell) + (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) + (dboard:graph-dat-flag-set! graph-dat #f))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))) + )))) ;;====================================================================== ;; R U N ;;====================================================================== ;; @@ -1413,144 +1524,197 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) + ;; (let ((existing (tree:find-node tb run-path))) + ;; (if (not existing) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)))) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) run-ids))) - -(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + +(define (dashboard:tests-ht->tests-dat tests-ht) + (reverse + (sort + (hash-table-values tests-ht) + (lambda (a b) + (let ((a-test-name (db:test-get-testname a)) + (a-item-path (db:test-get-item-path a)) + (b-test-name (db:test-get-testname b)) + (b-item-path (db:test-get-item-path b))) + (cond + ((< 0 (string-compare3 a-test-name b-test-name)) #t) + ((> 0 (string-compare3 a-test-name b-test-name)) #f) + ((< 0 (string-compare3 a-item-path b-item-path)) #t) + (else #f))))))) + + +(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) + (let* ((run (hash-table-ref/default runs-hash run-id #f)) + (key-vals (rmt:get-key-vals run-id)) + (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) + (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) + (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) + (when (not run) + (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (BB> "runs-hash-> " (hash-table->alist runs-hash)) + ) + tests-mindat)) + +(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) + (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) + (dest-run-id (dboard:tabdat-curr-run-id tabdat))) + (if (and src-run-id dest-run-id) + (dcommon:xor-tests-mindat + (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + hide-clean: hide-clean) + #f))) + + +(define (dashboard:get-runs-hash tabdat) + (let* ((last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht))) - (dboard:update-tree tabdat runs-hash runs-header tb) + runs) ht))) + runs-hash)) + + +(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) + (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) + (dashboard:do-update-rundat tabdat)) + (dboard:runs-summary-control-panel-updater tabdat) + (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (dashboard:get-runs-hash tabdat)) + ;; (runs-hash (let ((ht (make-hash-table))) + ;; (for-each (lambda (run) + ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + ;; runs) + ;; ht)) + ) + (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree) + (dboard:update-tree tabdat runs-hash runs-header tb)) (if run-id - (let* ( - - (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)) - (db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f) - (let* ((db-dir (tasks:get-task-db-path)) - (db-pth (conc db-dir "/" run-id ".db"))) - (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth) - db-pth))) - (tests-dat (if (or (not run-id) - (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") - (not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id)) - (>= (file-modification-time db-path) last-update)) - (dboard:get-tests-dat tabdat run-id last-update) - (hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id))) - (tests-mindat (dcommon:minimize-test-data tests-dat)) - (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - ) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) - (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) - (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - ;; Update the runs tree - (dboard:update-tree tabdat runs-hash runs-header tb) - - (if (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) - - (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) - (iup:attribute-set! run-matrix "NUMCOL" max-col )) - - (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) - (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) - (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - ;; (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - ;; (print "entry: " entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - tests-mindat) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (if (<= num max-col) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-log-port* "one-run-updater, changed: " changed " pass-num: " pass-num) - ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) - - ) + (let* ((matrix-content + (case (dboard:tabdat-runs-summary-mode tabdat) + ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) + ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) + (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) + (when matrix-content + (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + ) + + (dboard:tabdat-filters-changed-set! tabdat #f) + (let loop ((pass-num 0) + (changed #f)) + ;; Update the runs tree + ;; (dboard:update-tree tabdat runs-hash runs-header tb) + + (if (eq? pass-num 1) + (begin ;; big reset + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) + + (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + (iup:attribute-set! run-matrix "NUMCOL" max-col )) + + (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + ;; (print "row-indices: " row-indices " col-indices: " col-indices) + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass + + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + ;; (print "RA=> value" (car value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + matrix-content) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (if (<= num max-col) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) + col-indices) + + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass due to column labels changing + + ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; @@ -1643,20 +1807,103 @@ (if success (begin ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) result-child)) + + + +(define (dboard:runs-summary-buttons-updater tabdat) + (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) + (modes-left (dboard:tabdat-runs-summary-modes tabdat))) + (if (or (null? buttons-left) (null? modes-left)) + #t + (let* ((this-button (car buttons-left)) + (mode-item (car modes-left)) + (this-mode (car mode-item)) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (current-mode (dboard:tabdat-runs-summary-mode tabdat))) + (if (eq? this-mode current-mode) + (iup:attribute-set! this-button "BGCOLOR" sel-color) + (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) + (loop (cdr buttons-left) (cdr modes-left)))))) + +(define (dboard:runs-summary-xor-labels-updater tabdat) + (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat))) + (when (and source-runname-label dest-runname-label) + (case mode + ((xor-two-runs xor-two-runs-hide-clean) + (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-runname (if curr-run-id + (rmt:get-run-name-from-id curr-run-id) + "None")) + (prev-runname (if prev-run-id + (rmt:get-run-name-from-id prev-run-id) + "None"))) + (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) + (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) + (else + (iup:attribute-set! source-runname-label "TITLE" "") + (iup:attribute-set! dest-runname-label "TITLE" "")))))) + +(define (dboard:runs-summary-control-panel-updater tabdat) + (dboard:runs-summary-xor-labels-updater tabdat) + (dboard:runs-summary-buttons-updater tabdat)) + + +;; setup buttons and callbacks to switch between modes in runs summary tab +;; +(define (dashboard:runs-summary-control-panel tabdat) + (let* ((summary-buttons ;; build buttons + (map + (lambda (mode-item) + (let* ((this-mode (car mode-item)) + (this-mode-label (cdr mode-item))) + (iup:button this-mode-label + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) + (dboard:runs-summary-control-panel-updater tabdat)) + "runs summary control panel updater"))))) + (dboard:tabdat-runs-summary-modes tabdat))) + (summary-buttons-hbox (apply iup:hbox summary-buttons)) + (xor-runname-labels-hbox + (iup:hbox + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10" ))) + (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) + temp-label + ) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10"))) + (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) + temp-label)))) + (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) + + ;; maybe wrap in a frame + (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) + (dboard:runs-summary-control-panel-updater tabdat) + res + ))) + + ;;====================================================================== ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time ;; This is the Run Summary tab ;; -(define (dashboard:one-run commondat tabdat #!key (tab-num #f)) +(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" @@ -1668,60 +1915,118 @@ ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) (if (number? run-id) (begin + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; (dashboard:update-run-summary-tab) ) ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) ))) - "selection-cb in one-run") + "selection-cb in runs-summary") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb + (lambda (obj lin col status) - (let* ((toolpath (car (argv))) - (key (conc lin ":" col)) - (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) - (system cmd))))) - (one-run-updater + (debug:catch-and-dump + (lambda () + + ;; Bummer - we dont have the global get/set api mapped in chicken + ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) + ;; (BB> "modkeys="modkeys)) + + (BB> "click-cb: obj="obj" lin="lin" col="col" status="status) + ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path))) + (status-chars (char-set->list (string->char-set status))) + (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) + (BB> "status-chars=["status-chars"] status=["status"]") + (cond + ((member #\1 status-chars) ;; 1 is left mouse button + (system testpanel-cmd)) + + ((member #\2 status-chars) ;; 2 is middle mouse button + + (BB> "mmb- test-name="test-name" testpatt="testpatt) + (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + (else + (BB> "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + ) + + )) "runs-summary-click-callback")))) + (runs-summary-updater (lambda () (mutex-lock! update-mutex) - (if (or (dashboard:database-changed? commondat tabdat) + (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that run-matrix is initialized before calling the updater (if run-matrix - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))) - "dashboard:one-run-updater") + (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) + "dashboard:runs-summary-updater") ) - (mutex-unlock! update-mutex)))) - (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) + (mutex-unlock! update-mutex))) + (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) + ) + (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split + #:value 200 tb run-matrix) - (dboard:make-controls commondat tabdat)))) + (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (dboard:make-controls commondat tabdat) +(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) ) (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" - (iup:hbox + (iup:vbox + (iup:hbox (iup:vbox (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump @@ -1772,10 +2077,11 @@ #:dropdown "YES" #:action (lambda (obj val index lbstate) (set! *tests-sort-reverse* index) (mark-for-update tabdat)))) (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) (set! hide-empty (iup:button "HideEmpty" ;; #:expand HORIZONTAL" #:expand "NO" #:size "80x15" @@ -1799,14 +2105,25 @@ (iup:attribute-set! hide "BGCOLOR" nonsel-color) (mark-for-update tabdat)))) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... - (iup:vbox - (iup:hbox hide show) - hide-empty sort-lb))) - ))) + (iup:vbox + (iup:hbox hide show) + sort-lb))) + ) + + ;; insert extra widget here + (if extra-widget + extra-widget + (iup:hbox)) ;; empty widget + + + + + ))) + (iup:frame #:title "state/status filter" (iup:vbox (apply iup:hbox @@ -1844,24 +2161,66 @@ (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) #:min 0 #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) + ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) ))) -(define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path) +(define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) (iup:menu + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (let* ((toolpath (car (argv))) + (testpanel-cmd + (conc toolpath " -test " run-id "," test-id " &"))) + (system testpanel-cmd) + ))) + + (iup:menu-item + (conc "View Log (not yet implemented) " item-test-path) + ) + + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + + (iup:menu-item "Run" (iup:menu (iup:menu-item (conc "Rerun " testpatt) #:action (lambda (obj) - ;; (print "buttndat: " buttndat " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) (common:run-a-command (conc "megatest -run -target " target " -runname " runname " -testpatt " testpatt " -preclean -clean-cache") @@ -1880,11 +2239,20 @@ #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname - " -testpatt % ")))))) + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))))) (iup:menu-item "Test" (iup:menu (iup:menu-item (conc "Rerun " item-test-path) @@ -1939,11 +2307,11 @@ )))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) - (onerun-dat (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)) (keynames (dboard:tabdat-dbkeys runs-dat)) @@ -2069,11 +2437,11 @@ "%"))) (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) - (iup:show (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") )) @@ -2148,11 +2516,11 @@ (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 - (dashboard:one-run commondat onerun-dat tab-num: 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) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) @@ -2197,16 +2565,10 @@ (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) -(define (dashboard:been-changed tabdat) - (> (file-modification-time (dboard:tabdat-dbfpath tabdat)) (dboard:tabdat-last-db-update tabdat))) - -(define (dashboard:set-db-update-time tabdat) - (dboard:tabdat-last-db-update-set! tabdat (file-modification-time (dboard:tabdat-dbfpath tabdat)))) - (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) @@ -2221,11 +2583,11 @@ (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (apply max (map (lambda (filen) + (common:max (map (lambda (filen) (file-modification-time filen)) (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db")))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) @@ -2239,22 +2601,35 @@ (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) #t) #f))) -(define (dashboard:database-changed? commondat tabdat) +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! - (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat)))) - (dboard:commondat-please-update-set! commondat #f) - recalc)) + (recalc (dashboard:recalc modtime + (dboard:commondat-please-update commondat) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) +;;Not reference anywhere +;; ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) @@ -2285,20 +2660,10 @@ (cons (cons x1 x2) (hash-table-ref/default rowhash (+ i rownum) '()))) (if (< i num-rows) (loop (+ i 1))))) -;; get min or max, use > for max and < for min, this works around the limits on apply -;; -(define (dboard:min-max comp lst) - (if (null? lst) - #f ;; better than an exception for my needs - (fold (lambda (a b) - (if (comp a b) a b)) - (car lst) - lst))) - ;; sort a list of test-ids by the event _time using a hash table of id => testdat ;; (define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht) (sort test-ids (lambda (a b) @@ -2378,18 +2743,18 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) + ;; (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) (begin (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids)) ;; (print "Updating rundat") @@ -2401,13 +2766,15 @@ (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/") '("%" "%")) (make-list num-keys "%")) num-keys) )) - (runpatt (if (dboard:tabdat-target tabdat) - (last (dboard:tabdat-target tabdat)) - "%")) + (runpatt (if (and (dboard:tabdat-target tabdat) + (list? (dboard:tabdat-target tabdat)) + (not (null? (dboard:tabdat-target tabdat)))) + (last (dboard:tabdat-target tabdat)) + "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) @@ -2515,11 +2882,11 @@ (apply vector tstart (cdr zeropt)) (hash-table-ref/default res-ht fieldname '()))))))) fields) res-ht) #f))))) - + ;; graph data ;; tsc=timescale, tfn=function; time->x ;; (define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) (let* ((dwg (dboard:tabdat-drawing tabdat)) @@ -2527,11 +2894,15 @@ (cnv (dboard:tabdat-cnv tabdat)) (dur (- tstart tend)) ;; time duration (cmp (vg:get-component dwg "runslib" compname)) (cfg (configf:get-section *configdat* "graph")) (stdcolor (vg:rgb->number 120 130 140)) - (delta-y (- uly lly))) + (delta-y (- uly lly)) + (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (graph-matrix (dboard:tabdat-graph-matrix tabdat)) + (changed #f)) (vg:add-obj-to-comp cmp (vg:make-rect-obj llx lly ulx uly)) (vg:add-obj-to-comp cmp @@ -2556,68 +2927,98 @@ (lambda (cf) (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) (if alldat (for-each (lambda (fieldn) - (let* ((dat (hash-table-ref alldat fieldn)) - (vals (map (lambda (x)(vector-ref x 2)) dat))) - (if (not (null? vals)) - (let* ((maxval (apply max vals)) - (minval (min 0 (apply min vals))) - (yoff (- minval lly)) ;; minval)) - (deltaval (- maxval minval)) - (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) - (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) - (graph-color (vg:generate-color))) - ;; (print (car cf) "; maxval: " maxval " minval: " minval " deltaval: " deltaval " yscale: " yscale) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) - (fold - (lambda (next prev) ;; #(time ? val) #(time ? val) - (if prev - (let* ((yval (vector-ref prev 2)) - (yval-next (vector-ref next 2)) - (last-tval (tfn (vector-ref prev 0))) - (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) - (next-yval (yfunc yval-next)) - (curr-tval (tfn (vector-ref next 0)))) - (if (>= curr-tval last-tval) - (begin - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj last-tval last-yval curr-tval last-yval - line-color: graph-color)) - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj curr-tval last-yval curr-tval next-yval - line-color: graph-color))) - (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) - next) - ;; for init create vector tstart,0 - #f ;; (vector tstart minval minval) - dat) - - ;; (for-each - ;; (lambda (dpt) - ;; (let* ((tval (vector-ref dpt 0)) - ;; (yval (vector-ref dpt 2)) - ;; (stval (tfn tval)) - ;; (syval (yfunc yval))) - ;; (vg:add-obj-to-comp - ;; cmp - ;; (vg:make-rect-obj (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - ;; fill-color: stdcolor)))) - ;; dat) - )))) ;; for each data point in the series + (let*-values (((dat) (hash-table-ref alldat fieldn)) + ((vals minval maxval) (if (null? dat) + (values '() #f #f) + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '()) + (min (vector-ref (car dat) 2)) + (max (vector-ref (car dat) 2))) + (let* ((val (vector-ref hed 2)) + (newmin (if (< val min) val min)) + (newmax (if (> val max) val max)) + (newres (cons val res))) + (if (null? tal) + (values (reverse res) newmin newmax) + (loop (car tal)(cdr tal) newres newmin newmax))))))) + (if (not (hash-table-exists? graph-matrix-table fieldn)) + (begin + (let* ((graph-color-rgb (vg:generate-color-rgb)) + (graph-color (vg:iup-color->number graph-color-rgb)) + (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) + (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat)) + (graph-cell (conc graph-matrix-row ":" graph-matrix-col)) + (graph-dat (make-dboard:graph-dat + id: fieldn + color: graph-color + flag: #t + cell: graph-cell + ))) + (hash-table-set! graph-matrix-table fieldn graph-dat) + (hash-table-set! graph-cell-table graph-cell graph-dat) + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + (set! changed #t) + (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn) + (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb) + (if (> graph-matrix-col 10) + (begin + (dboard:tabdat-graph-matrix-col-set! tabdat 1) + (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) + (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) + ))) + (if (not (null? vals)) + (let* (;; (maxval (apply max vals)) + ;; (minval (min 0 (apply min vals))) + (yoff (- minval lly)) ;; minval)) + (deltaval (- maxval minval)) + (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) + (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + (graph-dat (hash-table-ref graph-matrix-table fieldn)) + (graph-color (dboard:graph-dat-color graph-dat)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (begin + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) + (fold + (lambda (next prev) ;; #(time ? val) #(time ? val) + (if prev + (let* ((yval (vector-ref prev 2)) + (yval-next (vector-ref next 2)) + (last-tval (tfn (vector-ref prev 0))) + (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) + (next-yval (yfunc yval-next)) + (curr-tval (tfn (vector-ref next 0)))) + (if (>= curr-tval last-tval) + (begin + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj last-tval last-yval curr-tval last-yval + line-color: graph-color)) + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj curr-tval last-yval curr-tval next-yval + line-color: graph-color))) + (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + next) + #f ;; (vector tstart minval minval) + dat) + )))))) ;; for each data point in the series (hash-table-keys alldat))))) - cfg))) + cfg) + (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) ;; run times tab ;; (define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) ;; each test is an object in the run component @@ -2637,11 +3038,12 @@ (compact-layout (dboard:tabdat-compact-layout tabdat)) (row-height (if compact-layout 2 10)) (graph-height 120) (run-to-run-margin 25)) (dboard:tabdat-layout-update-ok-set! tabdat #t) - (if (canvas? cnv) + (if (and (canvas? cnv) + (not (null? allruns))) ;; allruns can go null when browsing the runs tree (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv)) ((calc-y) (lambda (rownum) (- (/ sizey 2) (* rownum row-height)))) @@ -2682,12 +3084,12 @@ (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat (testsdat (hash-table-values tests-ht)) (runcomp (vg:comp-new));; new component for this run (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) ;; (row-height 4) - (run-start (dboard:min-max < (map db:test-get-event_time testsdat))) - (run-end (let ((re (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) + (run-start (common:min-max < (map db:test-get-event_time testsdat))) + (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) (run-duration (- run-end run-start)) (timescale (/ (- sizex (* 2 canvas-margin)) (if (> run-duration 0) @@ -2842,125 +3244,120 @@ (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))))))) ;; new-run-start-row ))) (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) + +;; handy trick for printing a record +;; +;; (pp (dboard:tabdat->alist tabdat)) +;; +;; removing the tabdat-values proc +;; +;; (define (tabdat-values tabdat) + +;; runs update-rundat using the various filters from the gui +;; +(define (dashboard:do-update-rundat tabdat) + (update-rundat + tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) + (let ((fres (if (dboard:tabdat-target tabdat) + (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) + (map (lambda (k v)(list k v)) dbkeys ptparts)) + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + (if val (set! res (cons (list key val) res)))))) + dbkeys) + res)))) + fres)))) (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))) - (update-rundat tabdat - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - (dboard:tabdat-numruns tabdat) - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") - (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) - ;; (print "dbkeys: " dbkeys) - (let ((fres (if (dboard:tabdat-target tabdat) - (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) - (map (lambda (k v)(list k v)) dbkeys ptparts)) - (let ((res '())) - ;; (print "target: " (dboard:tabdat-target tabdat)) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) - (if val (set! res (cons (list key val) res)))))) - dbkeys) - res)))) - ;; (debug:print 0 *default-log-port* "fres: " fres) - fres))) + ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) + ;;(tabdat-values tabdat) ;;RA added + ;; (pp (dboard:tabdat->alist tabdat)) + (dashboard:do-update-rundat 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")) -;; ((2) -;; (dashboard:update-run-summary-tab)) -;; ((3) -;; (dashboard:update-new-view-tab)) -;; (else -;; (dboard:common-run-curr-updater commondat))) -;; (set! *last-recalc-ended-time* (current-milliseconds)))))))) - ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== +(define (main) + (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + (if (and (file-exists? mtdb-path) + (file-write-access? mtdb-path)) + (if (not (args:get-arg "-skip-version-check")) + (common:exit-on-version-changed))) + (let* ((commondat (dboard:commondat-make))) + ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... + (cond + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (dashboard-tests:examine-test run-id test-id) + (begin + (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ;; ((args:get-arg "-guimonitor") + ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) + (else + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data) + (dboard:commondat-curr-tab-num-set! commondat 0) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 1)) + tab-num: 1) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (time-obj) + (let ((update-is-running #f)) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (set! update-is-running (dboard:commondat-updating commondat)) + (if (not update-is-running) + (dboard:commondat-updating-set! commondat #t)) + (mutex-unlock! (dboard:commondat-update-mutex commondat)) + (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update + (begin + (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (dboard:commondat-updating-set! commondat #f) + (mutex-unlock! (dboard:commondat-update-mutex commondat))) + )) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th2) + (thread-join! th2))))) + ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(define (main) - (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed)) - (let* ((commondat (dboard:commondat-make))) - ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... - (cond - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (if (> (length d) 1) - d - (list #f #f)))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) - (>= test-id 0)) - (examine-test run-id test-id) - (begin - (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) - (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data) - ;; (dboard:tabdat-numruns tabdat) - ;; (dboard:tabdat-num-tests tabdat) - ;; (dboard:tabdat-dbkeys tabdat) - ;; runs-sum-dat new-view-dat)) - ;; legacy setup of updaters for summary tab and runs tab - ;; summary tab - ;; (dboard:commondat-add-updater - ;; commondat - ;; (lambda () - ;; (dashboard:summary-tab-updater commondat 0)) - ;; tab-num: 0) - ;; runs tab - (dboard:commondat-curr-tab-num-set! commondat 0) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (time-obj) - (let ((update-is-running #f)) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) - )) - 1)))) - - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. - ;; (dashboard:run-update commondat) - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - ;; (thread-start! th1) - (thread-start! th2) - (thread-join! th2)))) - (main) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2013, Matthew Welland. +;; Copyright 2006-2016, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -11,14 +11,16 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) +;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc + +(require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension? +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records) (import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) +(import (prefix base64 base64:)) ;; RADT => prefix?? (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -31,23 +33,43 @@ (include "run_records.scm") (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +(defstruct dbr:dbstruct + main + strdb + ((path #f) : string) + ((local #f) : boolean) + rundb + inmem + mtime + rtime + stime + inuse + refdb + ((locdbs (make-hash-table)) : hash-table) + olddb) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (print "err-status: " err-status) (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)))) -;; convert to -inline +;; convert to -inline +;; (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) @@ -64,11 +86,11 @@ ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct run-id) +(define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin (let ((dbdat (if (or (not run-id) (eq? run-id 0)) @@ -75,10 +97,11 @@ (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) dbdat)))) +;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) @@ -88,30 +111,30 @@ #f)) ;; mod-read: ;; 'mod modified data ;; 'read read data +;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct ;; (define (db:done-with dbstruct run-id mod-read) (if (not (sqlite3:database? dbstruct)) (begin (mutex-lock! *rundb-mutex*) (if (eq? mod-read 'mod) - (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds)) - (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) - (dbr:dbstruct-set-inuse! dbstruct #f) + (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) + (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) + (dbr:dbstruct-inuse-set! dbstruct #f) (mutex-unlock! *rundb-mutex*)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) - (let* ((dbdat (if (vector? dbstruct) + (let* ((dbdat (if (dbr:dbstruct? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db (db:dbdat-get-db dbdat))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) @@ -143,10 +166,12 @@ ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) +;; +;; If run-id is #f return to create and retrieve the path where the db will live. ;; (define (db:dbfile-path run-id) (let* ((dbdir (db:get-dbdir)) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) @@ -156,24 +181,26 @@ (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname - (conc dbdir "/" fname) + (conc dbdir "/" fname) dbdir))) +;; Returns the database location as specified in config file +;; (define (db:get-dbdir) (or (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) + (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; open an sql database inside a file lock -;; ;; returns: db existed-prior-to-opening +;; RA => Returns a db handler; sets the lock if opened in writable mode ;; (define (db:lock-create-open fname initproc) ;; (if (file-exists? fname) ;; (let ((db (sqlite3:open-database fname))) ;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) @@ -188,24 +215,29 @@ (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) (db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists)(initproc db)) + (if (not file-exists) + (begin + (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (print "Creating " fname " in NON-WAL mode.")) + (initproc db))) ;; (release-dot-lock fname) db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (sqlite3:open-database fname))))) ;; ) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((local (dbr:dbstruct-get-local dbstruct)) + (let* ((local (dbr:dbstruct-local dbstruct)) (rdb (if local - (dbr:dbstruct-get-localdb dbstruct run-id) - (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) + (dbr:dbstruct-localdb dbstruct run-id) + (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb (begin (mutex-lock! *rundb-mutex*) @@ -240,36 +272,36 @@ (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; only unset so other db's also can use this control - (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) - (dbr:dbstruct-set-inuse! dbstruct #t) - (dbr:dbstruct-set-olddb! dbstruct olddb) - ;; (dbr:dbstruct-set-run-id! dbstruct run-id) + (dbr:dbstruct-rundb-set! dbstruct (cons db dbpath)) + (dbr:dbstruct-inuse-set! dbstruct #t) + (dbr:dbstruct-olddb-set! dbstruct olddb) + ;; (dbr:dbstruct-run-id-set! dbstruct run-id) (mutex-unlock! *rundb-mutex*) (if local (begin - (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... + (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ... db) (begin - (dbr:dbstruct-set-inmem! dbstruct inmem) + (dbr:dbstruct-inmem-set! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context (db:sync-tables db:sync-tests-only db inmem) (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) + (dbr:dbstruct-refdb-set! dbstruct refdb) (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem))))))) -;; This routine creates the db. It is only called if the db is not already ls opened +;; This routine creates the db if not already present. It is only called if the db is not already ls opened ;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let ((mdb (dbr:dbstruct-get-main dbstruct))) +(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((mdb (dbr:dbstruct-main dbstruct))) ;; RA => Returns the first reference in dbstruct (if mdb mdb (begin (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path 0)) @@ -278,25 +310,35 @@ (olddb (db:open-megatest-db)) (write-access (file-write-access? dbpath)) (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - (dbr:dbstruct-set-main! dbstruct dbdat) - (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) + (dbr:dbstruct-main-set! dbstruct dbdat) + (dbr:dbstruct-olddb-set! dbstruct olddb) ;; olddb is already a (cons db path) (mutex-unlock! *rundb-mutex*) (if (and (not dbexists) *db-write-access*) ;; did not have a prior db and do have write access (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically dbdat))))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) +;; open the local db for direct access (no server) +;; +(define (db:open-local-db-handle) + (or *dbstruct-db* + (let ((dbstruct (db:setup #f local: #t))) + (set! *dbstruct-db* dbstruct) + dbstruct))) + ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db) (let* ((dbpath (conc *toppath* "/megatest.db")) (dbexists (file-exists? dbpath)) @@ -310,18 +352,18 @@ (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) - (stime (dbr:dbstruct-get-stime dbstruct)) - (rundb (dbr:dbstruct-get-rundb dbstruct)) - (inmem (dbr:dbstruct-get-inmem dbstruct)) - (maindb (dbr:dbstruct-get-main dbstruct)) - (refdb (dbr:dbstruct-get-refdb dbstruct)) - (olddb (dbr:dbstruct-get-olddb dbstruct)) - ;; (runid (dbr:dbstruct-get-run-id dbstruct)) + (let ((mtime (dbr:dbstruct-mtime dbstruct)) + (stime (dbr:dbstruct-stime dbstruct)) + (rundb (dbr:dbstruct-rundb dbstruct)) + (inmem (dbr:dbstruct-inmem dbstruct)) + (maindb (dbr:dbstruct-main dbstruct)) + (refdb (dbr:dbstruct-refdb dbstruct)) + (olddb (dbr:dbstruct-olddb dbstruct)) + ;; (runid (dbr:dbstruct-run-id dbstruct)) ) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) (if (eq? run-id 0) ;; runid equal to 0 is main.db @@ -332,11 +374,11 @@ force-sync) (begin (db:delay-if-busy maindb) (db:delay-if-busy olddb) (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. @@ -349,33 +391,33 @@ (> mtime stime) force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) - (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (dbr:dbstruct-stime-set! dbstruct (current-milliseconds)) (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) ;; (mutex-unlock! *http-mutex*) num-synced) (begin ;; (mutex-unlock! *http-mutex*) 0)))))) (define (db:close-main dbstruct) - (let ((maindb (dbr:dbstruct-get-main dbstruct))) + (let ((maindb (dbr:dbstruct-main dbstruct))) (if maindb (begin (sqlite3:finalize! (db:dbdat-get-db maindb)) - (dbr:dbstruct-set-main! dbstruct #f))))) + (dbr:dbstruct-main-set! dbstruct #f))))) (define (db:close-run-db dbstruct run-id) (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) (if (and rdb (sqlite3:database? rdb)) (begin (sqlite3:finalize! rdb) - (dbr:dbstruct-set-localdb! dbstruct run-id #f) - (dbr:dbstruct-set-inmem! dbstruct #f))))) + (dbr:dbstruct-localdb-set! dbstruct run-id #f) + (dbr:dbstruct-inmem-set! dbstruct #f))))) ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db (db:sync-touched dbstruct 0 force-sync: #t) @@ -382,11 +424,11 @@ ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? (db:close-main dbstruct) - (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) + (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) (hash-table-keys locdbs))))) @@ -691,10 +733,74 @@ (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*))) + +(define (db:patch-schema-rundb run-id frundb) + ;; + ;; remove this some time after September 2016 (added in version v1.6031 + ;; + (for-each + (lambda (table-name) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") + (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) + (sqlite3:execute + frundb + (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) + (sqlite3:execute + frundb + (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) + (sqlite3:execute + frundb + (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " + FOR EACH ROW + BEGIN + UPDATE " table-name " SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;")) + ) + '("tests" "test_steps" "test_data"))) + +(define (db:patch-schema-maindb run-id maindb) + ;; + ;; remove all these some time after september 2016 (added in v1.6031 + ;; + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Column last_update already added to runs table") + (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) + (sqlite3:execute + maindb + "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) + ;; these schema changes don't need exception handling + (sqlite3:execute + maindb + "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + FOR EACH ROW + BEGIN + UPDATE runs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + id INTEGER PRIMARY KEY, + run_id INTEGER, + state TEXT, + status TEXT, + count INTEGER, + last_update INTEGER DEFAULT (strftime('%s','now')))") + (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;")) + ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges @@ -749,11 +855,11 @@ (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) - (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) + (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; @@ -762,93 +868,57 @@ (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) (count 1) (total (length all-run-ids)) (dead-runs '())) - (for-each - (lambda (run-id) - (debug:print 0 *default-log-port* "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) - (set! count (+ count 1)) - (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) - ;; (db:delay-if-busy frundb) - ;; (db:delay-if-busy mtdb) - ;; (db:clean-up frundb) - (if (eq? run-id 0) - (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) - (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))) - ;; - ;; Feb 18, 2016: add field last_update to runs table - ;; - ;; remove all these some time after september 2016 (added in v1.6031 - ;; - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) - (sqlite3:execute - maindb - "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) - ;; these schema changes don't need exception handling - (sqlite3:execute - maindb - "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - FOR EACH ROW - BEGIN - UPDATE runs SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( - id INTEGER PRIMARY KEY, - run_id INTEGER, - state TEXT, - status TEXT, - count INTEGER, - last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - ) - (begin - ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) - (db:clean-up-rundb (db:get-db fromdb run-id)) - ;; - ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data - ;; - ;; remove this some time after September 2016 (added in version v1.6031 - ;; - (for-each - (lambda (table-name) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") - (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (sqlite3:execute - frundb - (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute - frundb - (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute - frundb - (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " - FOR EACH ROW - BEGIN - UPDATE " table-name " SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;")) - ) - '("tests" "test_steps" "test_data")))))) - all-run-ids) - ;; removed deleted runs + ;; first fix schema if needed + (map + (lambda (th) + (thread-join! th)) + (map + (lambda (run-id) + (thread-start! + (make-thread + (lambda () + (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + (if (eq? run-id 0) + (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) + (db:patch-schema-maindb run-id maindb)) + (db:patch-schema-rundb run-id frundb))) + (set! count (+ count 1)) + (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total))))) + all-run-ids)) + ;; Then sync and fix db's + (set! count 0) + (process-fork + (lambda () + (map + (lambda (th) + (thread-join! th)) + (map + (lambda (run-id) + (thread-start! + (make-thread + (lambda () + (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + (if (eq? run-id 0) + (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) + (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) + (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) + (begin + ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db + (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) + (db:clean-up-rundb (db:get-db fromdb run-id))))) + (set! count (+ count 1)) + (debug:print 0 *default-log-port* "Finished clean up of " + (if (eq? run-id 0) + " main.db " (conc run-id ".db")) ", " count " of " total))))) + all-run-ids)))) + + ;; removed deleted runs (let ((dbdir (tasks:get-task-db-path))) (for-each (lambda (run-id) (let ((fullname (conc dbdir "/" run-id ".db"))) (if (file-exists? fullname) (begin @@ -1334,10 +1404,15 @@ (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))) + +;; 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) + ;; 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','LAUNCED')); @@ -1966,11 +2041,10 @@ ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time")))) (keystr (car tmp)) (header (cadr tmp)) - (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) (qry-str #f) (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) (for-each (lambda (keyval) @@ -1991,19 +2065,21 @@ " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (db:with-db dbstruct #f #f ;; reads db, does not write to it. - (lambda (db) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt))) - (vector header res))) + (vector header + (reverse + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:fold-row + (lambda (res . r) + (cons (list->vector r) res)) + '() + db + qry-str + runnamepatt))))))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) @@ -2997,14 +3073,14 @@ (string-substitute (regexp "=") "_" (base64:base64-encode (z3:encode-buffer (with-output-to-string - (lambda ()(serialize obj))))) + (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest. #t)) ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj)))) - (else obj))) + (else obj))) ;; rpc (define (db:string->obj msg #!key (transport 'http)) (case transport ;; ((fs) msg) ((http fs) @@ -3017,11 +3093,11 @@ (lambda ()(deserialize))) (begin (debug:print-error 0 *default-log-port* "reception failed. Received " msg " but cannot translate it.") msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) - (else msg))) + (else msg))) ;; rpc (define (db:test-set-status-state dbstruct run-id test-id status state msg) (let ((dbdat (db:get-db dbstruct run-id))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbdat 'set-test-start-time (list test-id))) @@ -3349,12 +3425,15 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) +;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval +;; return the sqlite3 db handle if possible +;; (define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (if (not (configf:lookup *configdat* "server" "delay-on-busy")) (and dbdat (db:dbdat-get-db dbdat)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) @@ -3361,11 +3440,11 @@ (if (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) + (db:delay-if-busy count (- count 1))) (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) @@ -3385,11 +3464,11 @@ (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else (debug:print-info 0 *default-log-port* "delaying db access due to high database load.") (thread-sleep! 12.8)))) - db) + db) "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -13,59 +13,61 @@ ;; ;; ;; Accessors for a dbstruct ;; -(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) -(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) -(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) -(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) -(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) -(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) -(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) -(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) -(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) -;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) -;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) - -(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) -(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) -(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) -(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) -(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) -(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) -(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) -(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) -(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) -(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) -(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) -(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) -(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) -(define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) -(define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) - -; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) +;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2)) +;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3)) +;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f ) +;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6)) +;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7)) +;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8)) +;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9)) +;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11)) +;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path ) +;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13)) +;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14)) +;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13)) +;; +;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val)) +;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val)) +;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val)) +;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val)) +;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val)) +;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val)) +;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val)) +;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val)) +;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val)) +;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val)) +;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val)) +;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val)) +;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val)) +;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val)) +;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val)) +;; +; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val)) ;; constructor for dbstruct ;; -(define (make-dbr:dbstruct #!key (path #f)(local #f)) - (let ((v (make-vector 15 #f))) - (dbr:dbstruct-set-path! v path) - (dbr:dbstruct-set-local! v local) - (dbr:dbstruct-set-locdbs! v (make-hash-table)) - v)) - -(define (dbr:dbstruct-get-localdb v run-id) - (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) - -(define (dbr:dbstruct-set-localdb! v run-id db) - (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) +;; (define (make-dbr:dbstruct #!key (path #f)(local #f)) +;; (let ((v (make-vector 15 #f))) +;; (dbr:dbstruct-path-set! v path) +;; (dbr:dbstruct-local-set! v local) +;; (dbr:dbstruct-locdbs-set! v (make-hash-table)) +;; v)) + +;; Returns the database for a particular run-id fron the dbstruct:localdbs +;; +(define (dbr:dbstruct-localdb v run-id) + (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) + +(define (dbr:dbstruct-localdb-set! v run-id db) + (hash-table-set! (dbr:dbstruct-locdbs v) run-id db)) (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) @@ -94,11 +96,11 @@ ;; replace runs:make-full-test-name with this routine (define (db:test-make-full-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) +(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) @@ -113,10 +115,11 @@ (define (db:test-get-is-toplevel vec) (and (equal? (db:test-get-item-path vec) "") ;; test is not an item (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path +;; RADT => purpose of mintest?? ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) (define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) (define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -12,11 +12,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) -(use regex defstruct) +(use regex typed-records) (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) @@ -24,10 +24,11 @@ (declare (uses synchash)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") +(include "run_records.scm") ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) (define dashboard:update-servers-table #f) @@ -215,11 +216,11 @@ (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 - (+ 1 (apply max rownums)))) + (+ 1 (common:max rownums)))) (hash-table-set! testname-to-row fullname rownum) ;; create the label (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc rownum ":" 0) @@ -259,10 +260,45 @@ (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) (list run-changes all-test-changes))) + +(define (dcommon:runsdat-get-col-num dat target runname force-set) + (let* ((runs-index (dboard:runsdat-runs-index dat)) + (col-name (conc target "/" runname)) + (res (hash-table-ref/default runs-index col-name #f))) + (if res + res + (if force-set + (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) + (hash-table-set! runs-index col-name max-col-num) + max-col-num))))) + +(define (dcommon:runsdat-get-row-num dat testname itempath force-set) + (let* ((tests-index (dboard:runsdat-runs-index dat)) + (row-name (conc testname "/" itempath)) + (res (hash-table-ref/default runs-index row-name #f))) + (if res + res + (if force-set + (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) + (hash-table-set! runs-index row-name max-row-num) + max-row-num))))) + +(define (dcommon:rundat-copy-tests-to-by-name rundat) + (let ((src-ht (dboard:rundat-tests rundat)) + (trg-ht (dboard:rundat-tests-by-name rundat))) + (if (and (hash-table? src-ht)(hash-table? trg-ht)) + (begin + (hash-table-clear! trg-ht) + (for-each + (lambda (testdat) + (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) + (hash-table-values src-ht))) + (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) + ;;====================================================================== ;; TESTS DATA ;;====================================================================== @@ -281,27 +317,135 @@ (status (db:test-get-status hed)) (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) + +(define (dcommon:tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (dcommon:status-compare3 status1 status2) + (let* + ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((not mem2) 1) + ((= (length mem1) (length mem2)) 0) + ((> (length mem1) (length mem2)) 1) + (else -1)))) + +(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) + (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) + (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (let ((res + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) + (dest-test-id (if dest-value (list-ref dest-value 0) #f)) + (dest-state (if dest-value (list-ref dest-value 1) #f)) + (dest-status (if dest-value (list-ref dest-value 2) #f)) + + (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) + (src-test-id (if src-value (list-ref src-value 0) #f)) + (src-state (if src-value (list-ref src-value 1) #f)) + (src-status (if src-value (list-ref src-value 2) #f)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (dcommon:status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) + ((not dest-complete) + (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) + ((not src-complete) + (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) + (else + (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) + ))) + (list test-name item-path xor-new-item))) + all-keys))) + + (if hide-clean + (filter + (lambda (item) + ;;(print item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) (define (dcommon:examine-xterm run-id test-id) (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (if (not testdat) - (begin - (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) + (begin + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) (let* ((rundir (if testdat - (db:test-get-rundir testdat) - logfile)) + (db:test-get-rundir testdat) + logfile)) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - "")) + (conc "-e " (get-environment-variable "SHELL")) + "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (print "Command =" command) (common:without-vars command @@ -315,21 +459,21 @@ ;;====================================================================== ;; Table of keys (define (dcommon:keys-matrix rawconfig) (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig "fields")) - (keys-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (length key-vals) - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys @@ -344,18 +488,18 @@ keys-matrix)) ;; Section to table (define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig sectionname)) - (section-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (min 10 (length key-vals)) + (key-vals (configf:section-vars rawconfig sectionname)) + (section-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) (iup:attribute-set! section-matrix "0:0" varcolname) (iup:attribute-set! section-matrix "0:1" valcolname) (iup:attribute-set! section-matrix "WIDTH1" "200") ;; fill in keys @@ -399,18 +543,18 @@ (define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (stats-updater (lambda () - (if (dashboard:database-changed? commondat tabdat) + (if (dashboard:database-changed? commondat tabdat context-key: 'run-stats) (let* ((run-stats (rmt:get-run-stats)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) - (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 - (apply max (map cadr col-indices)))) + (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) (max-col-vis (if (> max-col 10) 10 max-col)) (numrows 1) (numcols 1)) (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") @@ -452,12 +596,15 @@ (if (not (equal? (iup:attribute stats-matrix key) value)) (begin (set! changed #t) (iup:attribute-set! stats-matrix key value))))) run-stats) - (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))))) - (stats-updater) + (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))) + )))) + ;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass + ;; (mark-for-update tabdat) + ;; (stats-updater) (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num) ;; (set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") @@ -891,21 +1038,21 @@ ))) (dboard:tabdat-command-tb-set! data tb) tb) (iup:button "Execute" #:size "50x" #:action (lambda (obj) - (let ((cmd (conc "xterm -geometry 180x20 -e \"" - (iup:attribute (dboard:tabdat-command-tb data) "VALUE") - ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd))))))) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))))))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))))) (define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f)) (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs")) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) ;; (print obj " " val " " index " " lbstate) (dboard:tabdat-command-set! tabdat val) @@ -938,24 +1085,25 @@ (iup:attribute-set! tb "VALUE" val) (dboard:tabdat-run-name-set! tabdat val) (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () - (if (dashboard:database-changed? commondat tabdat) - (let* ((target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f 0)) + (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) + (let* (;; (target (dboard:tabdat-target-string tabdat)) + (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) + ;; (print "DEBUGINFO: run-names=" run-names) ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))) ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list) (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num) - (refresh-runs-list) + ;; (refresh-runs-list) (dboard:tabdat-run-name-set! tabdat default-run-name) (iup:hbox tb lb)))) @@ -973,13 +1121,14 @@ (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) #:expand "YES" - #:size "10x30" + #:size "x30" ;; was 10x30 #:multiline "YES"))) (set! test-patterns-textbox tb) + (dboard:tabdat-test-patterns-textbox-set! tabdat tb) tb)) ;; (iup:frame ;; #:title "Target" ;; ;; Target selectors ;; (apply iup:hbox @@ -1004,11 +1153,11 @@ (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:tabdat-statuses-set! tabdat all) (dashboard:update-run-command tabdat))))))) -(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state) +(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state) (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) @@ -1050,11 +1199,12 @@ (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) (scalef (hash-table-ref tests-draw-state 'scalef)) (sizey (hash-table-ref tests-draw-state 'sizey)) (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) - (new-y (- sizey y))) + (new-y (- sizey y)) + (test-patterns-textbox (dboard:tabdat-test-patterns-textbox tabdat))) ;; (print "xoffset=" xoffset ", yoffset=" yoffset) ;; (print "\tx\ty\tllx\tlly\turx\tury") (for-each (lambda (test-name) (let* ((rec-coords (hash-table-ref tests-info test-name)) (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) @@ -1066,21 +1216,25 @@ (if (and (eq? pressed 1) (>= x llx) (>= new-y lly) (<= x urx) (<= new-y ury)) - (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((box-patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))) + (test-patts (string-split (or (dboard:tabdat-test-patts tabdat) + "") + ",")) + (patterns (delete-duplicates (append box-patterns test-patts)))) (let* ((selected (not (member test-name patterns))) (newpatt-list (if selected (cons test-name patterns) (delete test-name patterns))) (newpatt (string-intersperse newpatt-list "\n"))) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (iup:attribute-set! obj "REDRAW" "ALL") (hash-table-set! selected-tests test-name selected) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (dboard:tabdat-test-patts-set!-use data (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command data) + (dboard:tabdat-test-patts-set!-use tabdat (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command tabdat) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) ;;====================================================================== ADDED defunct/multi-dboard.scm Index: defunct/multi-dboard.scm ================================================================== --- /dev/null +++ defunct/multi-dboard.scm @@ -0,0 +1,801 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) + +(declare (uses margs)) +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses tree)) +(declare (uses configf)) +(declare (uses portlogger)) +(declare (uses keys)) +(declare (uses common)) + +(include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") + +(define help (conc + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright (C) Matt Welland 2011 + +Usage: dashboard [options] + -h : this help + -group groupname : display this group of areas + -test testid : control test identified by testid + -guimonitor : control panel for runs + +Misc + -rows N : set number of rows +")) + +;; process args +(define remargs (args:get-args + (argv) + (list "-group" ;; display this group of areas + "-debug" + ) + (list "-h" + "-v" + "-q" + ) + args:arg-hash + 0)) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +;; (if (args:get-arg "-host") +;; (begin +;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (client:launch)) + +(define *runremote* #f) +(define *windows* (make-hash-table)) +(define *changed-main* (make-hash-table)) ;; set path/... => #t +(define *changed-mutex* (make-mutex)) ;; use for all incoming change requests +(define *searchpatts* (make-hash-table)) + +(debug:setup) + +(define *tim* (iup:timer)) +(define *ord* #f) + +(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "RUN" "YES") + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items . default) + (let ((i 1) + (selected-item (if (null? default) #f (car default)))) + (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (update-search x val) + (hash-table-set! *searchpatts* x val)) + + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; NOTE: Consider switching to defstruct. + +;; data for an area (regression or testsuite) +;; +(define-record areadat + name ;; area name + path ;; mt run area home + configdat ;; megatest config + denoise ;; focal point for not putting out same messages over and over + client-signature ;; key for client-server conversation + remote ;; hash of all the client side connnections + run-keys ;; target keys for this area + runs ;; used in dashboard, hash of run-ids -> rundat + read-only ;; can I write to this area? + monitordb ;; db handle for monitor.db + maindb ;; db handle for main.db + ) + +;; rundat, basic run data +;; +(define-record rundat + id ;; the run-id + target ;; val1/val2 ... corrosponding to run-keys in areadat + runname + state ;; state of the run, symbol + status ;; status of the run, symbol + event-time ;; when the run was initiated + tests ;; hash of test-id -> testdat, QUESTION: separate by run-id? + db ;; db handle + ) + +;; testdat, basic test data +(define-record testdat + run-id ;; what run is this from + id ;; test id + testname ;; test name + itempath ;; item path + state ;; test state, symbol + status ;; test status, symbol + event-time ;; when the test started + duration ;; how long the test took + ) + +;; general data for the dboard application +;; +(define-record data + cfgdat ;; data from ~/.megatest/.dat + areas ;; hash of areaname -> area-rec + current-window-id ;; + current-tab-id ;; + update-needed ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately + tabs ;; hash of tab-id -> areaname (??) should be of type "tab" + ) + +;; all the components of an area display, all fits into a tab but +;; parts may be swapped in/out as needed +;; +(define-record tab + tree + matrix ;; the spreadsheet + areadat ;; the one-structure (one day dbstruct will be put in here) + view-path ;; //... + view-type ;; standard, etc. + controls ;; the controls + data ;; all the data kept in sync with db + filters ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/.dat? + run-id ;; the current run-id + test-ids ;; the current test id hash, run-id => test-id + command ;; the command from the entry field + headers ;; hash of header -> colnum + rows ;; hash of rowname -> rownum + ) + +(define-record filter + target ;; hash of widgets for the target + runname ;; the runname widget + testpatt ;; the testpatt widget + ) + +;;====================================================================== +;; D B +;;====================================================================== + +;; These are all using sql-de-lite and independent of area so cannot use stuff +;; from db.scm + +;; NB// run-id=#f => return dbdir only +;; +(define (areadb:dbfile-path areadat run-id) + (let* ((cfgdat (areadat-configdat areadat)) + (dbdir (or (configf:lookup cfgdat "setup" "dbdir") + (conc (configf:lookup cfgdat "setup" "linktree") "/.db"))) + (fname (if run-id + (case run-id + ((-1) "monitor.db") + ((0) "main.db") + (else (conc run-id ".db"))) + #f))) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (exit 1)) + (if (not (directory? dbdir))(create-directory dbdir #t))) + (if fname + (conc dbdir "/" fname) + dbdir))) + +;; -1 => monitor.db +;; 0 => main.db +;; >1 => .db +;; +(define (areadb:open areadat run-id) + (let* ((runs (areadat-runs areadat)) + (rundat (if (> run-id 0) ;; it is a run + (hash-table-ref/default runs run-id #f) + #f)) + (db (case run-id ;; if already opened, get the db and return it + ((-1) (areadat-monitordb areadat)) + ((0) (areadat-maindb areadat)) + (else (if rundat + (rundat-db rundat) + #f))))) + (if db + db ;; merely return the already opened db + (let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it + (db (if (file-exists? dbfile) + (open-database dbfile) + (begin + (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.") + #f)))) + (case run-id + ((-1)(areadat-monitordb-set! areadat db)) + ((0) (areadat-maindb-set! areadat db)) + (else (rundat-db-set! rundat db))) + db)))) + +;; populate the areadat tests info, does NOT fill the tests data itself unless asked +;; +(define (areadb:populate-run-info areadat) + (let* ((runs (or (areadat-runs areadat) (make-hash-table))) + (keys (areadat-run-keys areadat)) + (maindb (areadb:open areadat 0))) + (if maindb + (query (for-each-row (lambda (row) + (let ((id (list-ref row 0)) + (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db + (print row) + (hash-table-set! runs id dat)))) + (sql maindb (conc "SELECT id," + (string-intersperse keys "||'/'||") + ",runname,state,status,event_time FROM runs WHERE state != 'deleted';"))) + (debug:print-error 0 *default-log-port* "no main.db found at " (areadb:dbfile-path areadat 0))) + areadat)) + +;; given an areadat and target/runname patt fill up runs data +;; +;; ?????/ + +;; given a list of run-ids refresh/retrieve runs data into areadat +;; +(define (areadb:fill-tests areadat #!key (run-ids #f)) + (let* ((runs (or (areadat-runs areadat) (make-hash-table)))) + (for-each + (lambda (run-id) + (let* ((rundat (hash-table-ref/default runs run-id #f)) + (tests (if (and rundat + (rundat-tests rundat)) ;; re-use existing hash table? + (rundat-tests rundat) + (let ((ht (make-hash-table))) + (rundat-tests-set! rundat ht) + ht))) + (rundb (areadb:open areadat run-id))) + (query (for-each-row (lambda (row) + (let* ((id (list-ref row 0)) + (testname (list-ref row 1)) + (itempath (list-ref row 2)) + (state (list-ref row 3)) + (status (list-ref row 4)) + (eventtim (list-ref row 5)) + (duration (list-ref row 6))) + (hash-table-set! tests id + (make-testdat run-id id testname itempath state status eventtim duration))))) + (sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';")))) + (or run-ids (hash-table-keys runs))) + areadat)) + + +;; initialize and refresh data +;; +(define (dboard:general-updater con port) + (for-each + (lambda (window-id) + ;; (print "Processing for window-id " window-id) + (let* ((window-dat (hash-table-ref *windows* window-id)) + (areas (data-areas window-dat)) + ;; (keys (areadat-run-keys area-dat)) + (tabs (data-tabs window-dat)) + (tab-ids (hash-table-keys tabs)) + (current-tab (if (null? tab-ids) + #f + (hash-table-ref tabs (car tab-ids)))) + (current-tree (if (null? tab-ids) #f (tab-tree current-tab))) + (current-node (if (null? tab-ids) 0 (string->number (iup:attribute current-tree "VALUE")))) + (current-path (if (eq? current-node 0) + "Areas" + (string-intersperse (tree:node->path current-tree current-node) "/"))) + (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab))) + (seen-nodes (make-hash-table)) + (path-changed (if current-tab + (equal? current-path (tab-view-path current-tab)) + #t))) + ;; (debug:print-info 0 *default-log-port* "Current path: " current-path) + ;; now for each area in the window gather the data + (if path-changed + (begin + (debug:print-info 0 *default-log-port* "clearing matrix - path changed") + (dboard:clear-matrix current-tab))) + (for-each + (lambda (area-name) + ;; (print "Processing for area-name " area-name) + (let* ((area-dat (hash-table-ref areas area-name)) + (area-path (areadat-path area-dat)) + (runs (areadat-runs area-dat))) + (if (hash-table-ref/default *changed-main* area-path 'processed) + (begin + (print "Processing " area-dat " for area-name " area-name) + (hash-table-set! *changed-main* area-path #f) + (areadb:populate-run-info area-dat) + (for-each + (lambda (run-id) + (let* ((run (hash-table-ref runs run-id)) + (target (rundat-target run)) + (runname (rundat-runname run))) + (if current-tree + (let* ((partial-path (append (string-split target "/")(list runname))) + (full-path (cons area-name partial-path))) + (if (not (hash-table-exists? seen-nodes full-path)) + (begin + (print "INFO: Adding node " partial-path " to section " area-name) + (tree:add-node current-tree "Areas" full-path) + (areadb:fill-tests area-dat run-ids: (list run-id)))) + (hash-table-set! seen-nodes full-path #t))))) + (hash-table-keys runs)))) + (if (or (equal? "Areas" current-path) + (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path)) + (dboard:redraw-area area-name area-dat current-tab current-matrix current-path)))) + (hash-table-keys areas)))) + (hash-table-keys *windows*))) + +;;====================================================================== +;; D A S H B O A R D D B +;;====================================================================== + +;; All moved to common.scm + +;;====================================================================== +;; T R E E +;;====================================================================== + +;; - - - - + +(define (dashboard:tree-browser data adat window-id) + ;; (iup:split + (let* ((tb (iup:treebox + #:value 0 + #:title "Areas" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((tree-path (tree:node->path obj id)) + (area (car tree-path)) + (areadat-path (cdr tree-path))) + #f + ;; (test-id (tree-path->test-id (cdr run-path)))) + ;; (if test-id + ;; (hash-table-set! (dboard:data-curr-test-ids *data*) + ;; window-id test-id)) + ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) + ))))) + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; (iup:attribute-set! tb "ADDEXPANDED" "NO") + ;; (dboard:data-tests-tree-set! *data* tb) + tb)) + +;;====================================================================== +;; M A I N M A T R I X +;;====================================================================== + +;; General displayer +;; +(define (dashboard:main-matrix data adat window-id) + (let* (;; (tab-dat (areadat- + (view-matrix (iup:matrix + ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)) + #:expand "YES" + ;; #:fittosize "YES" + #:resizematrix "YES" + #:scrollbar "YES" + #:numcol 100 + #:numlin 100 + #:numcol-visible 3 + #:numlin-visible 20 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE")))))) + + ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! view-matrix "WIDTH0" "100") + ;; (dboard:data-runs-matrix-set! *data* runs-matrix) + ;; (iup:hbox + ;; (iup:frame + ;; #:title "Runs browser" + ;; (iup:vbox + view-matrix)) + +;;====================================================================== +;; A R E A S +;;====================================================================== + +(define (dashboard:init-area data area-name apath) + (let* ((mtconf (dboard:read-mtconf apath)) + (area-dat (let ((ad (make-areadat + area-name ;; area name + apath ;; path to area + ;; 'http ;; transport + mtconf ;; megatest.config + (make-hash-table) ;; denoise hash + #f ;; client-signature + #f ;; remote connections + (keys:config-get-fields mtconf) ;; run keys + (make-hash-table) ;; run-id -> (hash of test-ids => dat) + (and (file-exists? apath)(file-write-access? apath)) ;; read-only + #f + #f + ))) + (hash-table-set! (data-areas data) area-name ad) + ad))) + area-dat)) + +;; given the keys for an area and a path from the tree browser +;; return the level: areas area runs run tests test +;; +(define (dboard:get-view-type keys current-path) + (let* ((path-parts (string-split current-path "/")) + (path-len (length path-parts))) + (cond + ((equal? current-path "Areas") 'areas) + ((eq? path-len 2) 'area) + ((<= (+ (length keys) 2) path-len) 'runs) + (else 'run)))) + +(define (dboard:clear-matrix tab) + (if tab + (begin + (iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL") + (tab-headers-set! tab (make-hash-table)) + (tab-rows-set! tab (make-hash-table))))) + +;; full redraw of a given area +;; +(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path) + (let* ((keys (areadat-run-keys area-dat)) + (runs (areadat-runs area-dat)) + (headers (tab-headers tab-dat)) + (rows (tab-rows tab-dat)) + (used-cols (hash-table-values headers)) + (used-rows (hash-table-values rows)) + (touched (make-hash-table)) ;; (vector row col) ==> true, touched cell + (view-type (dboard:get-view-type keys current-path)) + (changed #f) + (state-statuses (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED"))) + ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix) + (case view-type + ((areas) ;; find row for this area, if not found, create new entry + (let* ((curr-rownum (hash-table-ref/default rows area-name #f)) + (next-rownum (+ (apply max (cons 0 used-rows)) 1)) + (rownum (or curr-rownum next-rownum)) + (coord (conc rownum ":0"))) + (if (not curr-rownum)(hash-table-set! rows area-name rownum)) + (if (not (equal? (iup:attribute current-matrix coord) area-name)) + (begin + (let loop ((hed (car state-statuses)) + (tal (cdr state-statuses)) + (count 1)) + (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed)) + (iup:attribute-set! current-matrix (conc "0:" count) hed)) + (iup:attribute-set! current-matrix (conc rownum ":" count) "0") + (if (not (null? tal)) + (loop (car tal)(cdr tal)(+ count 1)))) + (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) + (iup:attribute-set! current-matrix coord area-name) + (set! changed #t)))))) + (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL")))) + + + + ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all + + + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + +(define (dashboard:area-panel aname data window-id) + (let* ((apath (configf:lookup (data-cfgdat data) aname "path")) ;; (hash-table-ref (dboard:data-cfgdat data) area-name)) + ;; (hash-table-ref (dboard:data-cfgdat data) aname)) + (area-dat (dashboard:init-area data aname apath)) + (tb (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data) + (ad (dashboard:main-matrix data area-dat window-id)) + (areas (data-areas data)) + (dboard-dat (make-tab + #f ;; tree + #f ;; matrix + area-dat ;; + #f ;; view path + 'default ;; view type + #f ;; controls + (make-hash-table) ;; cached data? not sure how to use this yet :) + #f ;; filters + #f ;; the run-id + (make-hash-table) ;; run-id -> test-id, for current test id + "" + (make-hash-table) ;; headername -> colnum + (make-hash-table) ;; rowname -> rownum + ))) + (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat) + (hash-table-set! (data-tabs data) window-id dboard-dat) + (tab-tree-set! dboard-dat tb) + (tab-matrix-set! dboard-dat ad) + (iup:split + #:value 200 + tb ad))) + + +;; Main Panel +;; +(define (dashboard:main-panel data window-id) + (iup:dialog + #:title "Megatest Control Panel" +;; #:menu (dcommon:main-menu data) + #:shrink "YES" + (iup:vbox + (let* ((area-names (hash-table-keys (data-cfgdat data))) + (area-panels (map (lambda (aname) + (dashboard:area-panel aname data window-id)) + area-names)) + (tabtop (apply iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (data-current-tab-id-set! data curr) + (data-update-needed-set! data #t) + (print "Tab is: " curr ", prev was " prev)) + area-panels)) + (tabs (data-tabs data))) + (if (not (null? area-names)) + (let loop ((index 0) + (hed (car area-names)) + (tal (cdr area-names))) + ;; (hash-table-set! tabs index hed) + (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard") + (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) + (if (not (null? tal)) + (loop (+ index 1)(car tal)(cdr tal))))) + tabtop)))) + + +;;====================================================================== +;; N A N O M S G S E R V E R +;;====================================================================== + +(define (dboard:server-service soc port) + (print "server starting") + (let loop ((msg-in (nn-recv soc)) + (count 0)) + (if (eq? 0 (modulo count 1000)) + (print "server received: " msg-in ", count=" count)) + (cond + ;; + ;; quit + ;; + ((equal? msg-in "quit") + (nn-send soc "Ok, quitting")) + ;; + ;; ping + ;; + ((and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "ping")) + (nn-send soc (conc (current-process-id))) + (loop (nn-recv soc)(+ count 1))) + ;; + ;; main changed + ;; + ((and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "main")) + (let ((parts (string-split msg-in " "))) + (hash-table-set! *changed-main* (cadr parts) #t) + (nn-send soc "got it!"))) + ;; + ;; ?? + ;; + (else + (nn-send soc "hello " msg-in " you got to the else clause!"))) + (loop (nn-recv soc)(if (> count 20000000) + 0 + (+ count 1))))) + +(define (dboard:one-time-ping-receive soc port) + (let ((msg-in (nn-recv soc))) + (if (and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "ping")) + (nn-send soc (conc (current-process-id)))))) + +(define (dboard:server-start given-port #!key (num-tries 200)) + (let* ((rep (nn-socket 'rep)) + (port (or given-port (portlogger:main "find"))) + (con (conc "tcp://*:" port))) + ;; register this connect here .... + (nn-bind rep con) + (thread-start! + (make-thread (lambda () + (dboard:one-time-ping-receive rep port)) + "one time receive thread")) + (if (dboard:ping-self "localhost" port) + (begin + (print "INFO: dashboard nanomsg server started on " port) + (values rep port)) + (begin + (print "WARNING: couldn't create server on port " port) + (portlogger:main "set" "failed") + (if (> num-tries 0) + (dboard:server-start #f (- num-tries 1)) + (begin + (print "ERROR: failed to start nanomsg server") + (values #f #f))))))) + +(define (dboard:server-close con port) + (nn-close con) + (portlogger:main "set" port "released")) + +(define (dboard:ping-self host port #!key (return-socket #t)) + ;; send a random number along with pid and check that we get it back + (let* ((req (nn-socket 'req)) + (key "ping") + (success #f) + (keepwaiting #t) + (ping (make-thread + (lambda () + (print "ping: sending string \"" key "\", expecting " (current-process-id)) + (nn-send req key) + (let ((result (nn-recv req))) + (if (equal? (conc (current-process-id)) result) + (begin + (print "ping, success: received \"" result "\"") + (set! success #t)) + (begin + (print "ping, failed: received key \"" result "\"") + (set! keepwaiting #f) + (set! success #f))))) + "ping")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after " count " seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for ping") + (thread-terminate! ping)))) + "timeout"))) + (nn-connect req (conc "tcp://" host ":" port)) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print "ping failed to connect to " host ":" port)) + (thread-start! timeout) + (thread-start! ping) + (thread-join! ping) + (if success (thread-terminate! timeout))) + (if return-socket + (if success req #f) + (begin + (nn-close req) + success)))) + +;;====================================================================== +;; C O N F I G U R A T I O N +;;====================================================================== + +;; Get the configuration file for a group name, if the group name is "default" and it doesn't +;; exist, create it and add the current path if it contains megatest.config +;; +(define (dboard:get-config group-name) + (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat"))) + (if (file-exists? fname) + (read-config fname (make-hash-table) #t) + (if (dboard:create-config fname) + (dboard:get-config group-name) + (make-hash-table))))) + +(define (dboard:create-config fname) + ;; (handle-exceptions + ;; exn + ;; + ;; #f ;; failed to create - just give up + (let* ((dirname (pathname-directory fname)) + (file-name (pathname-strip-directory fname)) + (curr-mtcfgdat (find-config "megatest.config" + toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory)))) + (curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f)) + (curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f))) + (if curr-mtpath + (begin + (debug:print-info 0 *default-log-port* "Creating config file " fname) + (if (not (file-exists? dirname)) + (create-directory dirname #t)) + (with-output-to-file fname + (lambda () + (let ((aname (pathname-strip-directory curr-mtpath))) + (print "[" aname "]") + (print "path " curr-mtpath)))) + #t) + (begin + (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat) + #f)))) +;; ) + +(define (dboard:read-mtconf apath) + (let* ((mtconffile (conc apath "/megatest.config"))) + (call-with-environment-variables + (list (cons "MT_RUN_AREA_HOME" apath)) + (lambda () + (read-config mtconffile (make-hash-table) #f)) ;; megatest.config + ))) + + +;;====================================================================== +;; G U I S T U F F +;;====================================================================== + +;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id +;;; +(define (dboard:make-window window-id) + (let* (;; (window-id 0) + (groupn (or (args:get-arg "-group") "default")) + (cfgdat (dboard:get-config groupn)) + ;; (cfgdat (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table))) + (data (make-data + cfgdat ;; this is the data from ~/.megatest for the selected group + (make-hash-table) ;; areaname -> area-rec + 0 ;; current window id + 0 ;; current tab id + #f ;; redraw needed for current tab id + (make-hash-table) ;; tab-id -> areaname + ))) + (hash-table-set! *windows* window-id data) + (iup:show (dashboard:main-panel data window-id)) + (iup:main-loop))) + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(define (main) + (let-values + (((con port)(dboard:server-start #f))) + (let ((portnum (if (string? port)(string->number port) port))) + ;; got here, monitor/dashboard was started + (mddb:register-dashboard portnum) + (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service")) + (thread-start! (make-thread (lambda () + (let loop () + (dboard:general-updater con portnum) + (thread-sleep! 1) + (loop))) "general updater")) + (dboard:make-window 0) + (mddb:unregister-dashboard (get-host-name) portnum) + (dboard:server-close con port)))) + ADDED defunct/nmsg-transport.scm Index: defunct/nmsg-transport.scm ================================================================== --- /dev/null +++ defunct/nmsg-transport.scm @@ -0,0 +1,358 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(import (prefix sqlite3 sqlite3:)) + +;; (use nanomsg) + +(declare (unit nmsg-transport)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tests)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses server)) + +(include "common_records.scm") +(include "db_records.scm") + +;; Transition to pub --> sub with pull <-- push +;; +;; 1. client sends request to server via push to the pull port +;; 2. server puts request in queue or processes immediately as appropriate +;; 3. server puts responses from completed requests into pub port +;; +;; TODO +;; +;; Done Tested +;; [x] [ ] 1. Add columns pullport pubport to servers table +;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 +;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports +;; [x] [ ] 4. Add client compose of request +;; [x] [ ] - name of client: testname/itempath-test_id-hostname +;; [x] [ ] - name of request: callname, params +;; [x] [ ] - request key: f(clientname, callname, params) +;; [x] [ ] 5. Add processing of subscription hits +;; [x] [ ] - done when get key +;; [x] [ ] - return results +;; [x] [ ] 6. Add timeout processing +;; [x] [ ] - after 60 seconds +;; [ ] [ ] i. check server alive, connect to new if necessary +;; [ ] [ ] ii. resend request +;; [ ] [ ] 7. Turn self ping back on + +(define (nmsg-transport:make-server-url hostport #!key (bindall #f)) + (if (not hostport) + #f + (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport)))) + +(define *server-loop-heart-beat* (current-seconds)) +(define *heartbeat-mutex* (make-mutex)) + +;;====================================================================== +;; S E R V E R +;;====================================================================== + +(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000)) + (debug:print 2 *default-log-port* "Attempting to start the server ...") + (let* ((start-port (portlogger:open-run-close portlogger:find-port)) + (server-thread (make-thread (lambda () + (nmsg-transport:try-start-server dbstruct run-id start-port server-id)) + "server thread")) + (tdbdat (tasks:open-db))) + (thread-start! server-thread) + (thread-sleep! 0.1) + (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id)) + (let ((interface (if (equal? hostn "-")(get-host-name) hostn))) + (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port) + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") + (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running + (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access + ;; (set! *inmemdb* dbstruct) + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") + (thread-start! (make-thread + (lambda ()(nmsg-transport:keep-running server-id run-id)) + "keep running")) + (thread-join! server-thread)) + (if (> retrynum 0) + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") + (portlogger:open-run-close portlogger:set-failed start-port) + (nmsg-transport:run dbstruct hostn run-id server-id)) + (begin + (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up") + (exit 1)))))) + +(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id) + (let ((repsoc (nn-socket 'rep))) + (nn-bind repsoc (conc "tcp://*:" portnum)) + (let loop ((msg-in (nn-recv repsoc))) + (let* ((dat (db:string->obj msg-in transport: 'nmsg))) + (debug:print 0 *default-log-port* "server, received: " dat) + (let ((result (api:execute-requests dbstruct dat))) + (debug:print 0 *default-log-port* "server, sending: " result) + (nn-send repsoc (db:obj->string result transport: 'nmsg))) + (loop (nn-recv repsoc)))))) + +;; all routes though here end in exit ... +;; +(define (nmsg-transport:launch run-id) + (let* ((tdbdat (tasks:open-db)) + (dbstruct (db:setup run-id)) + (hostn (or (args:get-arg "-server") "-"))) + (set! *run-id* run-id) + (set! *inmemdb* dbstruct) + ;; with nbfake daemonize isn't really needed + ;; + ;; (if (args:get-arg "-daemonize") + ;; (begin + ;; (daemon:ize) + ;; (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it + ;; (begin + ;; (current-error-port *alt-log-file*) + ;; (current-output-port *alt-log-file*))))) + (if (server:check-if-running run-id) + (begin + (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running") + (exit 0))) + (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) + (remtries 4)) + (if (not server-id) + (if (> remtries 0) + (begin + (thread-sleep! 2) + (if (not (server:check-if-running run-id)) + (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) + (- remtries 1)) + (begin + (debug:print-info 0 *default-log-port* "Another server took the slot, exiting") + (exit 0)))) + (begin + ;; since we didn't get the server lock we are going to clean up and bail out + (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") + )) + ;; locked in a server id, try to start up + (nmsg-transport:run dbstruct hostn run-id server-id)) + (set! *didsomething* #t) + (exit)))) + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== + +(define (nmsg-transport:mk-signature) + (message-digest-string (md5-primitive) + (with-output-to-string + (lambda () + (write (list (current-directory) + (argv))))))) + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +;; ping the server at host:port +;; return the open socket if successful (return-socket == #t) +;; expect the key expected-key returned in payload +;; send our-key or #f as payload +;; +(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f)) + ;; send a random number along with pid and check that we get it back + (let* ((host (if (or (not hostn) + (equal? hostn "-")) ;; use localhost + (get-host-name) + hostn)) + (req (or socket + (let ((soc (nn-socket 'req))) + (nn-connect soc (conc "tcp://" host ":" port)) + soc))) + (success #t) + (dat (vector "ping" our-key)) + (result (condition-case + (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout) + ((timeout)(set! success #f) #f))) + (key (if success + (vector-ref result 1) + #f))) + (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) + (if (and success + (or (not expected-key) ;; just getting a reply is good enough then + (equal? key expected-key))) + (if return-socket + req + (begin + (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it + #t)) + (begin + (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect + #f)))) + +;; send data to server, wait max of timeout seconds for a response. +;; return #( success/fail result ) +;; +;; for effiency it is easier to do the obj->string and string->obj here. +;; +(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25)) + (let* ((success #f) + (result #f) + (keepwaiting #t) + (dat (db:obj->string indat transport: 'nmsg)) + (send-recv (make-thread + (lambda () + (nn-send socreq dat) + (let* ((res (nn-recv socreq))) + (set! success #t) + (set! result (db:string->obj res transport: 'nmsg)))) + "send-recv")) + (timeout (make-thread + (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...") + (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for ping") + (thread-terminate! send-recv)))) + "timeout"))) + ;; replace with condition-case? + (handle-exceptions + exn + (set! result "timeout") + (thread-start! timeout) + (thread-start! send-recv) + (thread-join! send-recv) + (if success (thread-terminate! timeout))) + ;; raise timeout error if timed out + (if success + (if (and (vector? result) + (vector-ref result 0)) ;; did it fail at the server? + result ;; nope, all good + (begin + (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2)) + (debug:print 0 *default-log-port* " client call chain:") + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " server call chain:") + (pp (vector-ref result 1) (current-error-port)) + (signal (vector-ref result 0)))) + (signal (make-composite-condition + (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) + +;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being +;; used and to shutdown after sometime if it is not. +;; +(define (nmsg-transport:keep-running server-id run-id) + ;; if none running or if > 20 seconds since + ;; server last used then start shutdown + ;; This thread waits for the server to come alive + (let* ((server-info (let loop () + (let ((sdat #f)) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *server-info*) + (mutex-unlock! *heartbeat-mutex*) + (if sdat + (begin + (debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat) + sdat) + (begin + (thread-sleep! 0.5) + (loop)))))) + (iface (car server-info)) + (port (cadr server-info)) + (last-access 0) + (tdbdat (tasks:open-db)) + (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) + (if (and (string? tmo) + (string->number tmo)) + (* 60 60 (string->number tmo)) + ;; (* 3 24 60 60) ;; default to three days + (* 60 1) ;; default to one minute + ;; (* 60 60 25) ;; default to 25 hours + )))) + (print "Keep-running got server pid " server-id ", using iface " iface " and port " port) + (let loop ((count 0)) + (thread-sleep! 4) ;; no need to do this very often + ;; NB// sync currently does NOT return queue-length + (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) + ;; (print "Server running, count is " count) + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1))) + + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + (db:sync-touched *inmemdb* run-id force-sync: #t) + (if (and *server-run* + (> (+ last-access server-timeout) + (current-seconds))) + (begin + (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (loop 0)) + (begin + (debug:print-info 0 *default-log-port* "Starting to shutdown the server.") + (set! *time-to-exit* #t) + (db:sync-touched *inmemdb* run-id force-sync: #t) + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running") + (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") + (exit) + )))))) + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +(define (nmsg-transport:client-connect iface portnum) + (let* ((reqsoc (nmsg-transport:ping iface portnum return-socket: #t))) + (vector iface portnum #f #f #f (current-seconds) reqsoc))) + +;; returns result, there is no sucess/fail flag - handled via excpections +;; +(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5)) + ;; NB// In the html version of this routine there is a call to + ;; tasks:kill-server-run-id when there is an exception + (mutex-lock! *http-mutex*) + (let* ((packet (vector cmd param)) + (reqsoc (http-transport:server-dat-get-socket connection-info)) + (res (nmsg-transport:client-api-send-receive-raw reqsoc packet))) +;; (status (vector-ref rawres 0)) +;; (result (vector-ref rawres 1))) + (mutex-unlock! *http-mutex*) + res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result)))) + +;;====================================================================== +;; J U N K +;;====================================================================== + +;; DO NOT USE +;; +(define (nmsg-transport:client-signal-handler signum) + (handle-exceptions + exn + (debug:print 0 *default-log-port* " ... exiting ...") + (let ((th1 (make-thread (lambda () + (if (not *received-response*) + (receive-message* *runremote*))) ;; flush out last call if applicable + "eat response")) + (th2 (make-thread (lambda () + (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (thread-sleep! 3) ;; give the flush three seconds to do it's stuff + (debug:print 0 *default-log-port* " Done.") + (exit 4)) + "exit on ^C timer"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) + Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -825,10 +825,11 @@

1.2. Get List of Runs

URL: <base>/runs

Method: GET

Filter Params: target, testpatt, offset, limit

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs % -target % -dumpmode json -fields runs:runname,id+tests:state,status:id

Response:

[ { @@ -864,10 +865,11 @@

1.3. Trigger a new Run

URL: <base>/runs

Method: POST

+

Megatest Cmd: megatest -runtests % -target <target> :runname <run_name> -run

Request Params:

{"target": "target_value", "runname" : "runname", "test_pattern": "optional test pattern"}

@@ -901,10 +903,11 @@

1.4. Get perticular Run

URL: <base>/runs/:id

Method: GET

Filter Params: testpatt

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs <runname> -target % -dumpmode json -fields runs:runname,id+tests:state,status:id

Response:

[ { @@ -952,10 +955,11 @@

1.6. Get List of tests within a run

URL: <base>/runs/:id/tests

Method: GET

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs <runname> -target % -dumpmode json -fields runs:runname,id+tests:state,status:id

Response:

[ "tests" : @@ -979,10 +983,11 @@

1.8. Get perticular test that belongs to a Runs

URL: <base>/runs/:id/tests/:id

Method: GET

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs <runname> -target % -testpattern <pattern> -dumpmode json -fields runs:runname,id+tests:state,status:id

Response:

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

@@ -1010,10 +1015,10 @@
Index: docs/api.txt ================================================================== --- docs/api.txt +++ docs/api.txt @@ -40,10 +40,12 @@ Method: GET Filter Params: target, testpatt, offset, limit +Megatest Cmd: megatest -start-dir -list-runs % -target % -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== [ @@ -84,10 +86,12 @@ URL: /runs Method: POST +Megatest Cmd: megatest -runtests % -target :runname -run + Request Params: ================== {"[blue]#target#": "target_value", "[blue]#runname#" : "runname", "[blue]#test_pattern#": "optional test pattern"} ================== @@ -127,10 +131,13 @@ URL: /runs/:id Method: GET Filter Params: testpatt + +Megatest Cmd: megatest -start-dir -list-runs -target % -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== [ @@ -188,10 +195,13 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ URL: /runs/:id/tests Method: GET + +Megatest Cmd: megatest -start-dir -list-runs -target % -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== [ "[red]#tests#" : @@ -222,10 +232,13 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ URL: /runs/:id/tests/:id Method: GET + +Megatest Cmd: megatest -start-dir -list-runs -target % -testpattern -dumpmode json -fields runs:runname,id+tests:state,status:id + Response: ================== {"[blue]#id#": "4", "[blue]#name#":"test1", "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} Index: docs/dashboard.png ================================================================== --- docs/dashboard.png +++ docs/dashboard.png cannot compute difference between binary files ADDED docs/inprogress/megatest-architecture-2.fig Index: docs/inprogress/megatest-architecture-2.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture-2.fig @@ -0,0 +1,28 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 750 975 5850 975 5850 7425 750 7425 750 975 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6000 975 9975 975 9975 7425 6000 7425 6000 975 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 1500 5250 1500 5250 2475 900 2475 900 1500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 2625 5250 2625 5250 3675 900 3675 900 2625 +2 3 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 8 + 5325 1500 5325 5850 900 5850 900 7275 5700 7275 5700 1425 + 5250 1425 5325 1500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 3750 5250 3750 5250 4725 900 4725 900 3750 +4 0 0 50 -1 0 12 0.0000 4 165 1170 975 1275 megatest.exe\001 +4 0 0 50 -1 0 12 0.0000 4 150 1275 6150 1275 dashboard.exe\001 +4 0 0 50 -1 0 12 0.0000 4 195 900 1050 1725 run engine\001 +4 0 0 50 -1 0 12 0.0000 4 150 780 975 2850 database\001 +4 0 0 50 -1 0 12 0.0000 4 195 2025 1050 6075 data transport - use http\001 +4 0 0 50 -1 0 12 0.0000 4 195 2325 975 3900 test or launch management\001 ADDED docs/inprogress/megatest-architecture-proposed.fig Index: docs/inprogress/megatest-architecture-proposed.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture-proposed.fig @@ -0,0 +1,488 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +6 600 1350 1575 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1125 1500 450 150 1125 1500 1575 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1124 2177 450 150 1124 2177 1574 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 675 1575 675 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1575 1500 1575 2175 +-6 +6 1875 825 2850 1875 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1950 1050 1950 1650 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2850 975 2850 1650 +-6 +6 3225 450 4200 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3300 675 3300 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 600 4200 1275 +-6 +6 3075 2925 4050 3975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3150 3150 3150 3750 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4050 3075 4050 3750 +-6 +6 7275 4050 12825 9675 +6 8175 4125 8400 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4575 8400 4575 8400 4800 8175 4800 8175 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4800 8400 4800 8400 5025 8175 5025 8175 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5025 8400 5025 8400 5250 8175 5250 8175 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5250 8400 5250 8400 5475 8175 5475 8175 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5475 8400 5475 8400 5700 8175 5700 8175 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5700 8400 5700 8400 5925 8175 5925 8175 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5925 8400 5925 8400 6150 8175 6150 8175 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6150 8400 6150 8400 6375 8175 6375 8175 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6375 8400 6375 8400 6600 8175 6600 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6600 8400 6600 8400 6825 8175 6825 8175 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6825 8400 6825 8400 7050 8175 7050 8175 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7050 8400 7050 8400 7275 8175 7275 8175 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7275 8400 7275 8400 7500 8175 7500 8175 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7500 8400 7500 8400 7725 8175 7725 8175 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7725 8400 7725 8400 7950 8175 7950 8175 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7950 8400 7950 8400 8175 8175 8175 8175 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8175 8400 8175 8400 8400 8175 8400 8175 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8400 8400 8400 8400 8625 8175 8625 8175 8400 +-6 +6 8475 4125 8700 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4125 8700 4125 8700 4350 8475 4350 8475 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4350 8700 4350 8700 4575 8475 4575 8475 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4575 8700 4575 8700 4800 8475 4800 8475 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4800 8700 4800 8700 5025 8475 5025 8475 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5025 8700 5025 8700 5250 8475 5250 8475 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5250 8700 5250 8700 5475 8475 5475 8475 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5475 8700 5475 8700 5700 8475 5700 8475 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5700 8700 5700 8700 5925 8475 5925 8475 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5925 8700 5925 8700 6150 8475 6150 8475 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6150 8700 6150 8700 6375 8475 6375 8475 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6375 8700 6375 8700 6600 8475 6600 8475 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6600 8700 6600 8700 6825 8475 6825 8475 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6825 8700 6825 8700 7050 8475 7050 8475 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7050 8700 7050 8700 7275 8475 7275 8475 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7275 8700 7275 8700 7500 8475 7500 8475 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7500 8700 7500 8700 7725 8475 7725 8475 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7725 8700 7725 8700 7950 8475 7950 8475 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7950 8700 7950 8700 8175 8475 8175 8475 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8175 8700 8175 8700 8400 8475 8400 8475 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8400 8700 8400 8700 8625 8475 8625 8475 8400 +-6 +6 8775 4125 9000 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4125 9000 4125 9000 4350 8775 4350 8775 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4350 9000 4350 9000 4575 8775 4575 8775 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4575 9000 4575 9000 4800 8775 4800 8775 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4800 9000 4800 9000 5025 8775 5025 8775 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5025 9000 5025 9000 5250 8775 5250 8775 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5250 9000 5250 9000 5475 8775 5475 8775 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5475 9000 5475 9000 5700 8775 5700 8775 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5700 9000 5700 9000 5925 8775 5925 8775 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5925 9000 5925 9000 6150 8775 6150 8775 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6150 9000 6150 9000 6375 8775 6375 8775 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6375 9000 6375 9000 6600 8775 6600 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6600 9000 6600 9000 6825 8775 6825 8775 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6825 9000 6825 9000 7050 8775 7050 8775 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7050 9000 7050 9000 7275 8775 7275 8775 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7275 9000 7275 9000 7500 8775 7500 8775 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7500 9000 7500 9000 7725 8775 7725 8775 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7725 9000 7725 9000 7950 8775 7950 8775 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7950 9000 7950 9000 8175 8775 8175 8775 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8175 9000 8175 9000 8400 8775 8400 8775 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8400 9000 8400 9000 8625 8775 8625 8775 8400 +-6 +6 9075 4125 9300 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4125 9300 4125 9300 4350 9075 4350 9075 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4350 9300 4350 9300 4575 9075 4575 9075 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4575 9300 4575 9300 4800 9075 4800 9075 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4800 9300 4800 9300 5025 9075 5025 9075 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5025 9300 5025 9300 5250 9075 5250 9075 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5250 9300 5250 9300 5475 9075 5475 9075 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5475 9300 5475 9300 5700 9075 5700 9075 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5700 9300 5700 9300 5925 9075 5925 9075 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5925 9300 5925 9300 6150 9075 6150 9075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6150 9300 6150 9300 6375 9075 6375 9075 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6375 9300 6375 9300 6600 9075 6600 9075 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6600 9300 6600 9300 6825 9075 6825 9075 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6825 9300 6825 9300 7050 9075 7050 9075 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7050 9300 7050 9300 7275 9075 7275 9075 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7275 9300 7275 9300 7500 9075 7500 9075 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7500 9300 7500 9300 7725 9075 7725 9075 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7725 9300 7725 9300 7950 9075 7950 9075 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7950 9300 7950 9300 8175 9075 8175 9075 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8175 9300 8175 9300 8400 9075 8400 9075 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8400 9300 8400 9300 8625 9075 8625 9075 8400 +-6 +6 9375 4125 9600 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4125 9600 4125 9600 4350 9375 4350 9375 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4350 9600 4350 9600 4575 9375 4575 9375 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4575 9600 4575 9600 4800 9375 4800 9375 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4800 9600 4800 9600 5025 9375 5025 9375 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5025 9600 5025 9600 5250 9375 5250 9375 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5250 9600 5250 9600 5475 9375 5475 9375 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5475 9600 5475 9600 5700 9375 5700 9375 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5700 9600 5700 9600 5925 9375 5925 9375 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5925 9600 5925 9600 6150 9375 6150 9375 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6150 9600 6150 9600 6375 9375 6375 9375 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6375 9600 6375 9600 6600 9375 6600 9375 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6600 9600 6600 9600 6825 9375 6825 9375 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6825 9600 6825 9600 7050 9375 7050 9375 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7050 9600 7050 9600 7275 9375 7275 9375 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7275 9600 7275 9600 7500 9375 7500 9375 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7500 9600 7500 9600 7725 9375 7725 9375 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7725 9600 7725 9600 7950 9375 7950 9375 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7950 9600 7950 9600 8175 9375 8175 9375 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 +-6 +# Dimension line: 1-1/16 in +6 7875 9375 9150 9675 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7875 9525 9150 9525 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7875 9375 7875 9675 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 9150 9375 9150 9675 +4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001 +-6 +# Dimension line: 1-11/16 in +6 7425 4125 7725 6150 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7575 4125 7575 6150 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 6150 7725 6150 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 4125 7725 4125 +4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001 +-6 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001 +4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001 +-6 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +6 4875 6075 5850 7125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5400 6225 450 150 5400 6225 5850 6375 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5399 6902 450 150 5399 6902 5849 7052 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4950 6300 4950 6900 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5850 6225 5850 6900 +-6 +6 5400 7425 7350 8925 +6 5475 7650 6450 8700 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 7800 450 150 6000 7800 6450 7950 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5999 8477 450 150 5999 8477 6449 8627 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 5550 7875 5550 8475 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6450 7800 6450 8475 +-6 +4 0 0 50 -1 0 12 0.0000 4 195 1905 5400 8850 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 5550 7575 monitor.db\001 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1725 5025 1275 2475 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5550 4500 5550 225 225 225 225 4500 5550 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1875 7725 1875 5775 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2775 5400 7125 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3675 7725 2175 5775 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6600 3300 2925 5025 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 9450 15525 8475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 11400 17175 11400 17175 11925 15825 11925 15825 11400 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 10125 16350 11400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 10875 18900 10875 18900 11400 17550 11400 17550 10875 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 9975 19725 9975 19725 10500 18375 10500 18375 9975 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 10125 17850 10875 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 9825 18375 10200 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 9975 18075 8700 15900 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 6225 19950 6225 19950 12150 14100 12150 14100 6225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16575 9375 17850 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2100 10425 6150 10425 6150 14400 2100 14400 2100 10425 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2325 10875 5925 10875 5925 13800 2325 13800 2325 10875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2400 10950 3975 10950 3975 11625 2400 11625 2400 10950 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3975 11250 4575 12075 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2175 5025 3075 3750 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4800 6375 2850 5550 +4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001 +4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1305 17700 7875 mysql/postgres\001 +4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 +4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 +4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 +4 0 0 50 -1 0 12 0.0000 4 195 2205 450 525 /tmp//??? /.db/*.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 4800 7350 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1785 600 8775 Possible Future state\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 8025 450 CHANGES:\001 +4 0 0 50 -1 0 12 0.0000 4 195 2145 8025 705 1. http -> rcp or nanomsg\001 +4 0 0 50 -1 0 12 0.0000 4 195 3330 8025 960 2. cache db moves from inmem to /tmp\001 ADDED docs/inprogress/megatest-architecture.fig Index: docs/inprogress/megatest-architecture.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-architecture.fig @@ -0,0 +1,528 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +6 600 1350 1575 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1125 1500 450 150 1125 1500 1575 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1124 2177 450 150 1124 2177 1574 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 675 1575 675 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1575 1500 1575 2175 +-6 +6 1875 825 2850 1875 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1950 1050 1950 1650 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 2850 975 2850 1650 +-6 +6 3225 450 4200 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3300 675 3300 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4200 600 4200 1275 +-6 +6 3075 2925 4050 3975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3150 3150 3150 3750 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 4050 3075 4050 3750 +-6 +6 7275 4050 12825 9675 +6 8175 4125 8400 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4125 8400 4125 8400 4350 8175 4350 8175 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4350 8400 4350 8400 4575 8175 4575 8175 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4575 8400 4575 8400 4800 8175 4800 8175 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 4800 8400 4800 8400 5025 8175 5025 8175 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5025 8400 5025 8400 5250 8175 5250 8175 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5250 8400 5250 8400 5475 8175 5475 8175 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5475 8400 5475 8400 5700 8175 5700 8175 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5700 8400 5700 8400 5925 8175 5925 8175 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 5925 8400 5925 8400 6150 8175 6150 8175 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6150 8400 6150 8400 6375 8175 6375 8175 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6375 8400 6375 8400 6600 8175 6600 8175 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6600 8400 6600 8400 6825 8175 6825 8175 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 6825 8400 6825 8400 7050 8175 7050 8175 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7050 8400 7050 8400 7275 8175 7275 8175 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7275 8400 7275 8400 7500 8175 7500 8175 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7500 8400 7500 8400 7725 8175 7725 8175 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7725 8400 7725 8400 7950 8175 7950 8175 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 7950 8400 7950 8400 8175 8175 8175 8175 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8175 8400 8175 8400 8400 8175 8400 8175 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8175 8400 8400 8400 8400 8625 8175 8625 8175 8400 +-6 +6 8475 4125 8700 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4125 8700 4125 8700 4350 8475 4350 8475 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4350 8700 4350 8700 4575 8475 4575 8475 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4575 8700 4575 8700 4800 8475 4800 8475 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 4800 8700 4800 8700 5025 8475 5025 8475 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5025 8700 5025 8700 5250 8475 5250 8475 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5250 8700 5250 8700 5475 8475 5475 8475 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5475 8700 5475 8700 5700 8475 5700 8475 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5700 8700 5700 8700 5925 8475 5925 8475 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 5925 8700 5925 8700 6150 8475 6150 8475 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6150 8700 6150 8700 6375 8475 6375 8475 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6375 8700 6375 8700 6600 8475 6600 8475 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6600 8700 6600 8700 6825 8475 6825 8475 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 6825 8700 6825 8700 7050 8475 7050 8475 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7050 8700 7050 8700 7275 8475 7275 8475 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7275 8700 7275 8700 7500 8475 7500 8475 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7500 8700 7500 8700 7725 8475 7725 8475 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7725 8700 7725 8700 7950 8475 7950 8475 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 7950 8700 7950 8700 8175 8475 8175 8475 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8175 8700 8175 8700 8400 8475 8400 8475 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8475 8400 8700 8400 8700 8625 8475 8625 8475 8400 +-6 +6 8775 4125 9000 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4125 9000 4125 9000 4350 8775 4350 8775 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4350 9000 4350 9000 4575 8775 4575 8775 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4575 9000 4575 9000 4800 8775 4800 8775 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 4800 9000 4800 9000 5025 8775 5025 8775 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5025 9000 5025 9000 5250 8775 5250 8775 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5250 9000 5250 9000 5475 8775 5475 8775 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5475 9000 5475 9000 5700 8775 5700 8775 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5700 9000 5700 9000 5925 8775 5925 8775 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 5925 9000 5925 9000 6150 8775 6150 8775 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6150 9000 6150 9000 6375 8775 6375 8775 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6375 9000 6375 9000 6600 8775 6600 8775 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6600 9000 6600 9000 6825 8775 6825 8775 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 6825 9000 6825 9000 7050 8775 7050 8775 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7050 9000 7050 9000 7275 8775 7275 8775 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7275 9000 7275 9000 7500 8775 7500 8775 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7500 9000 7500 9000 7725 8775 7725 8775 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7725 9000 7725 9000 7950 8775 7950 8775 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 7950 9000 7950 9000 8175 8775 8175 8775 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8175 9000 8175 9000 8400 8775 8400 8775 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8775 8400 9000 8400 9000 8625 8775 8625 8775 8400 +-6 +6 9075 4125 9300 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4125 9300 4125 9300 4350 9075 4350 9075 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4350 9300 4350 9300 4575 9075 4575 9075 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4575 9300 4575 9300 4800 9075 4800 9075 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 4800 9300 4800 9300 5025 9075 5025 9075 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5025 9300 5025 9300 5250 9075 5250 9075 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5250 9300 5250 9300 5475 9075 5475 9075 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5475 9300 5475 9300 5700 9075 5700 9075 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5700 9300 5700 9300 5925 9075 5925 9075 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 5925 9300 5925 9300 6150 9075 6150 9075 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6150 9300 6150 9300 6375 9075 6375 9075 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6375 9300 6375 9300 6600 9075 6600 9075 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6600 9300 6600 9300 6825 9075 6825 9075 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 6825 9300 6825 9300 7050 9075 7050 9075 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7050 9300 7050 9300 7275 9075 7275 9075 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7275 9300 7275 9300 7500 9075 7500 9075 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7500 9300 7500 9300 7725 9075 7725 9075 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7725 9300 7725 9300 7950 9075 7950 9075 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 7950 9300 7950 9300 8175 9075 8175 9075 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8175 9300 8175 9300 8400 9075 8400 9075 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9075 8400 9300 8400 9300 8625 9075 8625 9075 8400 +-6 +6 9375 4125 9600 8625 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4125 9600 4125 9600 4350 9375 4350 9375 4125 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4350 9600 4350 9600 4575 9375 4575 9375 4350 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4575 9600 4575 9600 4800 9375 4800 9375 4575 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 4800 9600 4800 9600 5025 9375 5025 9375 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5025 9600 5025 9600 5250 9375 5250 9375 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5250 9600 5250 9600 5475 9375 5475 9375 5250 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5475 9600 5475 9600 5700 9375 5700 9375 5475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5700 9600 5700 9600 5925 9375 5925 9375 5700 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 5925 9600 5925 9600 6150 9375 6150 9375 5925 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6150 9600 6150 9600 6375 9375 6375 9375 6150 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6375 9600 6375 9600 6600 9375 6600 9375 6375 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6600 9600 6600 9600 6825 9375 6825 9375 6600 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 6825 9600 6825 9600 7050 9375 7050 9375 6825 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7050 9600 7050 9600 7275 9375 7275 9375 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7275 9600 7275 9600 7500 9375 7500 9375 7275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7500 9600 7500 9600 7725 9375 7725 9375 7500 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7725 9600 7725 9600 7950 9375 7950 9375 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 7950 9600 7950 9600 8175 9375 8175 9375 7950 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8175 9600 8175 9600 8400 9375 8400 9375 8175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9375 8400 9600 8400 9600 8625 9375 8625 9375 8400 +-6 +# Dimension line: 1-1/16 in +6 7875 9375 9150 9675 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7875 9525 9150 9525 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7875 9375 7875 9675 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 9150 9375 9150 9675 +4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001 +-6 +# Dimension line: 1-11/16 in +6 7425 4125 7725 6150 +# main dimension line +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2 + 1 1 1.00 60.00 120.00 + 1 1 1.00 60.00 120.00 + 7575 4125 7575 6150 +# text box +2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5 + 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 6150 7725 6150 +# tick +2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 + 7425 4125 7725 4125 +4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001 +-6 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225 +2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150 +4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001 +4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001 +-6 +6 975 5100 1500 5700 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1258 5186 242 86 1258 5186 1500 5271 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1257 5573 242 86 1257 5573 1499 5658 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1015 5229 1015 5571 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 1500 5186 1500 5571 +-6 +6 3000 6075 3525 6675 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3283 6161 242 86 3283 6161 3525 6246 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3282 6548 242 86 3282 6548 3524 6633 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3040 6204 3040 6546 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 3525 6161 3525 6546 +-6 +6 7575 2625 8100 3225 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 7858 2711 242 86 7858 2711 8100 2796 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 7857 3098 242 86 7857 3098 8099 3183 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 7615 2754 7615 3096 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 8100 2711 8100 3096 +-6 +6 9525 450 10500 1500 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 10050 600 450 150 10050 600 10500 750 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 10049 1277 450 150 10049 1277 10499 1427 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 9600 675 9600 1275 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 10500 600 10500 1275 +-6 +6 14100 150 19950 6075 +6 14850 1350 15825 2400 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 1575 14925 2175 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 1500 15825 2175 +-6 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 3375 15525 2400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 4050 16350 5325 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 4050 17850 4800 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 3750 18375 4125 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 3900 18075 2625 15900 1875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 150 19950 150 19950 6075 14100 6075 14100 150 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001 +-6 +6 14850 7425 15825 8475 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 14925 7650 14925 8250 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 15825 7575 15825 8250 +-6 +6 17775 6675 18750 7725 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975 +1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 17850 6900 17850 7500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 18750 6825 18750 7500 +-6 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1725 5025 1275 2475 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5550 4500 5550 225 225 225 225 4500 5550 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1875 7725 1875 5775 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2775 5400 7125 5700 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 2400 7725 3900 6675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 4275 6075 3825 4200 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 7125 5850 4800 6300 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3675 7725 2175 5775 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 3975 7725 3975 6750 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 7125 825 8475 825 8475 1350 7125 1350 7125 825 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 4800 6675 4800 6075 3525 6075 3525 6675 4800 6675 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 7575 3225 7575 2625 6300 2625 6300 3225 7575 3225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 7650 1425 6975 2625 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6300 2925 2850 1725 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 6975 3300 7725 3900 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 7200 1350 5925 2550 5925 4875 4650 6000 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 4 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 1425 8025 825 6750 825 2850 900 2700 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 17025 10125 17025 9525 15750 9525 15750 10125 17025 10125 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16050 9450 15525 8475 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 15825 11400 17175 11400 17175 11925 15825 11925 15825 11400 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16350 10125 16350 11400 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 17550 10875 18900 10875 18900 11400 17550 11400 17550 10875 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 18375 9975 19725 9975 19725 10500 18375 10500 18375 9975 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16725 10125 17850 10875 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 17025 9825 18375 10200 +2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 18975 9975 18075 8700 15900 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 14100 6225 19950 6225 19950 12150 14100 12150 14100 6225 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2 + 0 0 1.00 60.00 120.00 + 0 0 1.00 60.00 120.00 + 16575 9375 17850 7950 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2100 10425 6150 10425 6150 14400 2100 14400 2100 10425 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2325 10875 5925 10875 5925 13800 2325 13800 2325 10875 +2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5 + 2400 10950 3975 10950 3975 11625 2400 11625 2400 10950 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 5325 12675 5325 12075 4050 12075 4050 12675 5325 12675 +2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3975 11250 4575 12075 +4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001 +4 0 0 50 -1 0 12 0.0000 4 180 1500 450 525 link tree /.db/*.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001 +4 0 0 50 -1 0 12 0.0000 4 150 1035 3675 6375 server-main\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001 +4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001 +4 0 0 50 -1 0 12 0.0000 4 180 870 7275 1050 run2/test1\001 +4 0 0 50 -1 0 12 0.0000 4 150 720 6375 2850 server-2\001 +4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001 +4 0 0 50 -1 0 12 0.0000 4 195 1905 9450 1650 pointers to the servers\001 +4 0 0 50 -1 0 12 0.0000 4 150 930 9600 375 monitor.db\001 +4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001 +4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001 +4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001 +4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001 +4 0 0 50 -1 0 12 0.0000 4 195 1305 17700 7875 mysql/postgres\001 +4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001 +4 0 0 50 -1 0 12 0.0000 4 150 1140 600 8775 Current state\001 +4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001 +4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001 ADDED docs/inprogress/megatest-query-view.fig Index: docs/inprogress/megatest-query-view.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest-query-view.fig @@ -0,0 +1,59 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 675 4350 675 4350 1650 900 1650 900 675 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4350 1200 6975 1725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6975 1350 10725 1350 10725 3075 6975 3075 6975 1350 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 7125 1800 8925 2025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 8850 1875 10125 1875 10125 2550 8850 2550 8850 1875 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9825 2550 10125 6000 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 11400 7350 11400 6000 9000 6000 9000 7350 11400 7350 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9750 6000 9375 2550 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 8775 2250 7125 2025 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 6975 1800 4350 1275 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 975 3600 4350 3600 4350 4575 975 4575 975 3600 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 5 + 0 0 1.00 60.00 120.00 + 1050 1650 1050 2025 4575 2025 4575 1050 4350 1050 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 4350 3825 6975 2700 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 9000 2625 4350 4200 +4 0 0 50 -1 0 12 0.0000 4 150 390 1050 975 Test\001 +4 0 0 50 -1 0 12 0.0000 4 150 585 7125 1650 Server\001 +4 0 0 50 -1 0 12 0.0000 4 195 1020 4800 1125 http request\001 +4 0 0 50 -1 0 12 0.0000 4 195 750 9075 2100 db query\001 +4 0 0 50 -1 0 12 0.0000 4 150 345 9525 6375 disk\001 +4 0 0 50 -1 0 12 0.0000 4 195 1905 1725 1200 (rmt:tests-get-info ....)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1905 1800 4125 (rmt:tests-get-info ....)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1110 5100 3300 send-request\001 +4 0 0 50 -1 0 12 0.0000 4 150 2145 5475 3900 call-back with result data\001 +4 0 0 50 -1 0 12 0.0000 4 150 390 1125 3750 Test\001 +4 0 0 50 -1 0 12 0.0000 4 195 675 7350 2550 api.scm\001 +4 0 0 50 -1 0 12 0.0000 4 195 990 7350 2805 recieve-req\001 +4 0 0 50 -1 0 12 0.0000 4 150 1515 7350 3060 send-res-callback\001 ADDED docs/inprogress/megatest_qa.fig Index: docs/inprogress/megatest_qa.fig ================================================================== --- /dev/null +++ docs/inprogress/megatest_qa.fig @@ -0,0 +1,38 @@ +#FIG 3.2 Produced by xfig version 3.2.5-alpha5 +Landscape +Center +Inches +Letter +100.00 +Single +-2 +1200 2 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 6000 300 6000 9675 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 525 675 4500 675 4500 2550 525 2550 525 675 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 900 1125 2325 1125 2325 1575 900 1575 900 1125 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 + 225 150 225 7050 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 525 3150 3750 3150 3750 4275 525 4275 525 3150 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 12750 5025 12750 750 6450 750 6450 5025 12750 5025 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9300 1725 10800 1725 10800 2100 9300 2100 9300 1725 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 9300 2175 10800 2175 10800 2550 9300 2550 9300 2175 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 6750 1275 12600 1275 12600 2925 6750 2925 6750 1275 +2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5 + 12450 2700 12450 1650 6975 1650 6975 2700 12450 2700 +4 0 0 50 -1 0 12 0.0000 4 120 405 675 900 tests\001 +4 0 0 50 -1 0 12 0.0000 4 195 900 975 1425 nested_mt\001 +4 0 0 50 -1 0 12 0.0000 4 195 2790 675 3375 nested_mt (a full megatest suite)\001 +4 0 0 50 -1 0 12 0.0000 4 165 1110 375 5100 megatest_qa\001 +4 0 0 50 -1 0 12 0.0000 4 150 420 525 300 code\001 +4 0 0 50 -1 0 12 0.0000 4 150 1005 6750 375 Actual runs\001 +4 0 0 50 -1 0 12 0.0000 4 165 1710 6675 1050 outer megatest runs\001 +4 0 0 50 -1 0 12 0.0000 4 195 1785 6900 1500 test (e.g. nested_mt)\001 +4 0 0 50 -1 0 12 0.0000 4 195 1665 7125 1875 nested_mt testsuite\001 Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -13,13 +13,16 @@ # asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 design_spec.txt # all : server.ps megatest_manual.html client.ps complex-itemmap.png -megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt *png +megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt installation.txt *png asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt # dos2unix megatest_manual.html + +megatest.pdf : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt *png + a2x -a toc -f pdf megatest_manual.txt server.ps : server.dot dot -Tps server.dot > server.ps client.ps : client.dot Index: docs/manual/getting_started.txt ================================================================== --- docs/manual/getting_started.txt +++ docs/manual/getting_started.txt @@ -1,81 +1,99 @@ Getting Started -=============== +--------------- [partintro] .Getting started with Megatest -- -How to install Megatest and set it up for running your regressions and continuous integration process. +Creating a testsuite or flow and your first test or task. -- -Installation ------------- - -Dependencies -~~~~~~~~~~~~ - -Chicken scheme and a number of "eggs" are required for building -Megatest. See the script installall.sch in the utils directory of the -distribution for a mostly automated way to install everything needed -for building Megatest on Linux. - -footnote:[An example footnote.] -indexterm:[Example index entry] - -// -// -// And now for something completely different: ((monkeys)), lions and -// tigers (Bengal and Siberian) using the alternative syntax index -// entries. -// (((Big cats,Lions))) -// (((Big cats,Tigers,Bengal Tiger))) -// (((Big cats,Tigers,Siberian Tiger))) -// Note that multi-entry terms generate separate index entries. -// -// Here are a couple of image examples: an image:images/smallnew.png[] -// example inline image followed by an example block image: -// -// .Tiger block image -// image::images/tiger.png[Tiger image] -// -// Followed by an example table: -// -// .An example table -// [width="60%",options="header"] -// |============================================== -// | Option | Description -// | -a 'USER GROUP' | Add 'USER' to 'GROUP'. -// | -R 'GROUP' | Disables access to 'GROUP'. -// |============================================== -// -// .An example example -// =============================================== -// Lorum ipum... -// =============================================== -// -// [[X1]] -// Sub-section with Anchor -// ~~~~~~~~~~~~~~~~~~~~~~~ -// Sub-section at level 2. -// -// Chapter Sub-section -// ^^^^^^^^^^^^^^^^^^^ -// Sub-section at level 3. -// -// Chapter Sub-section -// +++++++++++++++++++ -// Sub-section at level 4. -// -// This is the maximum sub-section depth supported by the distributed -// AsciiDoc configuration. -// footnote:[A second example footnote.] -// -// -// The Second Chapter -// ------------------ -// An example link to anchor at start of the <>. -// indexterm:[Second example index entry] -// -// An example link to a bibliography entry <>. -// -// +After installing Megatest you can create a flow or testsuite and add some +tests using the helpers. Here is a quickstart sequence to get you up and +running your first automated testsuite. + +Creating a Megatest Area +~~~~~~~~~~~~~~~~~~~~~~~~ + +Choose Target Keys +^^^^^^^^^^^^^^^^^^ + +First choose your "target" keys. These are used to organise your runs in a +way that is meaningful to your project. If you are unsure about what to use +for keys just use a single generic key such as "RUNTYPE". These keys will be +used to hand values to your tests via environment variables so ensure they +are unique. Prefixing them with something such as PROJKEYS_ is a good +strategy. + +Examples of keys: + +.Example keys +[width="60%",options="header"] +|============================================== +| Option | Description +| RELEASE/ITERATION | This example is used by Megatest for its internal QA. +| ARCH/OS/RELEASE | For a software project targeting multiple platforms +| UCTRLR/NODETYPE | Microcontroller project with different controllers +running same software +|============================================== + +Create Area Config Files +^^^^^^^^^^^^^^^^^^^^^^^^ + +You will need to choose locations for your runs (the data generated every +time you run the testsuite) and link tree. For getting started answer the +prompts with "runs" and "links". We use the Unix editor "vi" in the examples +below but you can use any plain text editor. + +.Using the helper to create a Megatest area +------------------ +megatest -create-megatest-area + +# optional: verify that the settings are ok +vi megatest.config +vi runconfigs.config +------------------ + +Creating a Test +~~~~~~~~~~~~~~~ + +Choose the test name for your first test and run the helper. You can edit +the files after the initial creation. You will need to enter names and +scripts for the steps to be run and then edit the +tests//testconfig file and modify the logpro rules to properly +process the log output from your steps. For your first test just hit enter +for the "waiton", "priority" and iteration variable prompts. + +Hint: for geting started make your logpro rules very liberal. expect:error +patterns should match nothing and comment out expect:required rules. + +.Using the helper to create a Megatest test +--------------- +megatest -create-test myfirsttest + +# then edit the generated config +vi tests/myfirsttest/testconfig +--------------- + +Running your test +~~~~~~~~~~~~~~~~~ + +First choose a target and runname. If you have a two-place target such as +RELEASE/ITERATION a target would look like v1.0/aff3 where v1.0 is the +RELEASE and aff3 is the ITERATION. For a run name just use something like +run1. + +.Running all tests (testpatt of "%" matches all tests) +--------------- +megatest -run -target v1.0/aff3 -runname run1 -testpatt % -log run1.log +--------------- + +Viewing the results +~~~~~~~~~~~~~~~~~~~ + +Start the dashboard and browse your run in the "Runs" tab. + +.Starting dashboard +---------------- +dashboard -rows 24 +---------------- Index: docs/manual/howto.txt ================================================================== --- docs/manual/howto.txt +++ docs/manual/howto.txt @@ -1,14 +1,14 @@ 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. @@ -21,30 +21,30 @@ ---------------- 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/% ---------------- @@ -78,17 +78,17 @@ # 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: @@ -102,13 +102,10 @@ --------------- [jobgroups] group1 10 custdes 4 --------------- - - - Debugging Tricks ---------------- Examining The Environment ADDED docs/manual/installation.txt Index: docs/manual/installation.txt ================================================================== --- /dev/null +++ docs/manual/installation.txt @@ -0,0 +1,10 @@ +Installation +------------ + +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. Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual + + +EOF +) + +(define (tests:run-record->test-path run numkeys) + (append (take (vector->list run) numkeys) + (list (vector-ref run (+ 1 numkeys))))) + +;; (tests:create-html-tree "test-index.html") +;; +(define (tests:create-html-tree outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '())) + (if (common:simple-file-lock lockfile) + (let* ((linktree (common:get-linktree)) + (oup (open-output-file (or outf (conc linktree "/runs-index.html")))) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (header (vector-ref runsdat 0)) + (runs (vector-ref runsdat 1)) + (runtreedat (map (lambda (x) + (tests:run-record->test-path x numkeys)) + runs)) + (runs-htree (common:list->htree runtreedat))) + (set! runs-to-process runs) + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (s:h1 "Summary for " area-name) + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Runs" + (common:htree->html runs-htree + '() + (lambda (x p) + (let* ((targ-path (string-intersperse p "/")) + (full-path (conc linktree "/" targ-path)) + (run-name (car (reverse p)))) + (if (and (file-exists? full-path) + (directory? full-path) + (file-write-access? full-path)) + (s:a run-name 'href (conc targ-path "/run-summary.html")) + (begin + (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") + (conc run-name " (Not able to create summary at " targ-path ")"))))))))))) + (close-output-port oup) + (common:simple-file-release-lock lockfile) + (for-each + (lambda (run) + (let* ((test-subpath (tests:run-record->test-path run numkeys)) + (run-id (db:get-value-by-header run header "id")) + (run-dir (tests:run-record->test-path run numkeys)) + (test-dats (rmt:get-tests-for-run + run-id + "%/" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (tests-tree-dat (map (lambda (test-dat) + ;; (tests:run-record->test-path x numkeys)) + (let* ((test-name (db:test-get-testname test-dat)) + (item-path (db:test-get-item-path test-dat)) + (full-name (db:test-make-full-name test-name item-path)) + (path-parts (string-split full-name))) + path-parts)) + test-dats)) + (tests-htree (common:list->htree tests-tree-dat)) + (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) + (html-path (conc html-dir "/run-summary.html")) + (oup (if (and (file-exists? html-dir) + (directory? html-dir) + (file-write-access? html-dir)) + (open-output-file html-path) + #f))) + ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) + (if oup + (begin + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + (s:h1 "Summary for " (string-intersperse run-dir "/")) + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Tests" + (common:htree->html tests-htree + '() + (lambda (x p) + (let* ((targ-path (string-intersperse p "/")) + (test-name (car p)) + (item-path ;; (if (> (length p) 2) ;; test-name + run-name + (string-intersperse p "/")) + (full-targ (conc html-dir "/" targ-path)) + (std-file (conc full-targ "/test-summary.html")) + (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) + (html-file (if (file-exists? alt-file) + alt-file + std-file)) + (run-name (car (reverse p)))) + (if (and (not (file-exists? full-targ)) + (directory? full-targ) + (file-write-access? full-targ)) + (tests:summarize-test + run-id + (rmt:get-test-id run-id test-name item-path))) + (if (file-exists? full-targ) + (s:a run-name 'href html-file) + (begin + (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) + (conc "No summary for " run-name))))) + )))))) + (close-output-port oup))))) + runs) + #t) + #f))) + ;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! ;; ;; get a pretty table to summarize steps ;; @@ -666,11 +863,12 @@ (conc (vector-ref b 2))) #f)) (string setup-chicken4x.sh -echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >> setup-chicken4x.sh +mkdir -p $PREFIX +echo "export PATH=$PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.sh +echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.sh +echo "export CHICKEN_DOC_PAGER=cat" >> $PREFIX/setup-chicken4x.sh + +echo "setenv PATH $PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.csh +echo "setenv LD_LIBRARY_PATH $LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.csh +echo "setenv CHICKEN_DOC_PAGER cat" >> $PREFIX/setup-chicken4x.csh echo PATH=$PATH echo LD_LIBRARY_PATH=$LD_LIBRARY_PATH if ! [[ -e $PREFIX/bin/csi ]]; then - tar xfvz tgz/$chicken_targz + tar xfz tgz/$chicken_targz cd chicken-${CHICKEN_VERSION} # make PLATFORM=linux PREFIX=$PREFIX spotless make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi +cd $BUILDHOME +#wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz +#mv 1.0.0 1.0.0.tar.gz +# if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then +# wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz +# mv 1.0.0 1.0.0.tar.gz +# tar xf 1.0.0.tar.gz +# cd nanomsg-1.0.0 +# ./configure --prefix=$PREFIX +# make +# make install +# fi +# cd $BUILDHOME + +export SQLITE3_VERSION=3090200 +if ! [[ -e $PREFIX/bin/sqlite3 ]]; then + echo Install sqlite3 + sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz + if ! [[ -e tgz/$sqlite3_tgz ]]; then + wget http://www.sqlite.org/2015/$sqlite3_tgz + mv $sqlite3_tgz tgz + fi + + if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then + if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then + tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz + (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) + fi + fi +fi +cd $BUILDHOME # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do # $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing -$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars s md5 message-digest piffy-directory-listing ssax sxml-serializer sxml-modifications logpro -# if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then -# $CHICKEN_INSTALL $PROX $f -# # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f -# else -# echo Skipping install of egg $f as it is already installed -# fi -# done - -cd $BUILDHOME - -for a in `ls */*.meta|cut -f1 -d/` ; do - echo $a - (cd $a;$CHICKEN_INSTALL) -done - -export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH -export LD_LIBRARY_PATH=$LIBPATH - -export SQLITE3_VERSION=3071401 -echo Install sqlite3 -sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz -if ! [[ -e tgz/$sqlite3_tgz ]]; then - wget http://www.sqlite.org/$sqlite3_tgz - mv $sqlite3_tgz tgz -fi - -if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then - if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then - tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz - (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) - # CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL -prefix $DEPLOYTARG -deploy $PROX sqlite3 - CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX sqlite3 - fi -fi +for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \ + coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \ + tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client \ + spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \ + sxml-modifications logpro z3 call-with-environment-variables \ + pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42 \ + alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \ + cock condition-utils debug define-record-and-printer easyffi easyffi-base \ + expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \ + locale locale-builtin locale-categories locale-components locale-current locale-posix \ + locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \ + sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \ + srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \ + udp uuid uuid-lib zlib + +do + echo "Installing $egg" + $CHICKEN_INSTALL $PROX -keep-installed $egg + #$CHICKEN_INSTALL $PROX $egg + if [ $? -ne 0 ]; then + echo "$egg failed to install" + exit 1 + fi +done + +if [[ -e `which mysql_config` ]]; then + $CHICKEN_INSTALL $PROX -keep-installed mysql-client +fi + +for egg in "sqlite3" sql-de-lite # nanomsg +do + echo "Installing $egg" + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg + #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg + if [ $? -ne 0 ]; then + echo "$egg failed to install" + exit 1 + fi +done +cd $BUILDHOME +cd `$PREFIX/bin/csi -p '(chicken-home)'` +curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx +cd $BUILDHOME + + # $CHICKEN_INSTALL $PROX sqlite3 - -# IUP versions -if [[ x$USEOLDIUP == "x" ]];then - CDVER=5.7 - IUPVER=3.8 - IMVER=3.8 -else - CDVER=5.7 - IUPVER=3.8 - IMVER=3.8 -fi +cd $BUILDHOME +# # IUP versions +# if [[ x$USEOLDIUP == "x" ]];then +# CDVER=5.10 +# IUPVER=3.17 +# IMVER=3.11 +# else +# CDVER=5.10 +# IUPVER=3.17 +# IMVER=3.11 +# fi +# if [[ x$KTYPE == "x24g3" ]];then +# CDVER=5.4.1 +# IUPVER=3.5 +# IMVER=3.6.3 +# fi if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ fi # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz" if [[ x$USEOLDIUP == "x" ]];then - export files="cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" + export files="cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" else echo WARNING: Using old IUP libraries - export files="cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" + export files="cd/cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" fi +echo $files mkdir -p $PREFIX/iuplib +mkdir -p iup/ for a in `echo $files` ; do if ! [[ -e tgz/$a ]] ; then - wget http://www.kiatoa.com/matt/iup/$a - mv $a tgz/$a + echo wget -c -O tgz/$a http://www.kiatoa.com/matt/chicken-build/$a + wget -c http://www.kiatoa.com/matt/chicken-build/$a + mv `echo $a | cut -d'/' -f2` tgz/ fi echo Untarring tgz/$a into $BUILDHOME/lib - (cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include) + tar -xzf tgz/`echo $a | cut -d'/' -f2` -C iup/ + #(cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include) # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a) done - +cp iup/include/* $PREFIX/include/ +cp iup/*.so $PREFIX/lib/ +cp iup/*.a $PREFIX/lib/ +cp iup/ftgl/lib/*/* $PREFIX/lib/ +cd $BUILDHOME # ffcall obtained from: # cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall - -if ! [[ -e tgz/ffcall.tar.gz ]] ; then - wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz - mv ffcall.tar.gz tgz +#exit +if ! [[ -e $PREFIX/include/callback.h ]] ; then + #fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + tar -xzf ffcall.tar.gz + #mkdir -p ffcall + cd ffcall + #fossil open ../ffcall.fossil + ./configure --prefix=$PREFIX --enable-shared + make CC="gcc -fPIC" + make install +fi +cd $BUILDHOME +#wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' +# Not working due to login problems. +if ! [[ -e $PREFIX/bin/hs ]] ; then + #fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + #mkdir -p opensrc + wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' + tar -xzf opensrc.tar.gz + cd opensrc + #fossil open ../opensrc.fossil + cd histstore + $PREFIX/bin/csc histstore.scm -o hs + cp -f hs $PREFIX/bin/hs + cd ../mutils + $PREFIX/bin/chicken-install + cd ../dbi + $PREFIX/bin/chicken-install + cd ../margs + $PREFIX/bin/chicken-install fi - -tar xfvz tgz/ffcall.tar.gz - -cd ffcall -./configure --prefix=$PREFIX --enable-shared -make -make install - +cd $BUILDHOME + +if ! [[ -e $PREFIX/bin/stmlrun ]] ; then + #fossil clone http://www.kiatoa.com/fossils/stml stml.fossil + wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' + tar -xzf stml.tar.gz + cd stml + #fossil open ../stml.fossil + cp install.cfg.template install.cfg + echo "TARGDIR=$PREFIX/bin" > install.cfg + echo "LOGDIR=/tmp/stmlrun" >> install.cfg + echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg + cp requirements.scm.template requirements.scm + which csc + make clean + CSCOPTS="-C -fPIC" make +fi cd $BUILDHOME export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` -CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup +IUPEGGVER='iup' +if [[ $IUPVER == "3.5" ]]; then + IUPEGGVER='iup:1.2.1' +fi + +#CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web $IUPEGGVER + # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup # iup:1.0.2 -CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw -# NB// Removed bunch of zmq compiling tricks. Look at older versions of this file if you need to recreate... - cd $BUILDHOME -# git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 -# cd zmq-3.2 -# chicken-install -# -# cd $BUILDHOME - -## WEBKIT=WebKit-r131972 -## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then -## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 -## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 -## fi -## -## if [[ x$only_it_worked == $I_wish ]] ;then -## if [[ -e ${WEBKIT}.tar.bz2 ]] ; then -## tar xfj ${WEBKIT}.tar.bz2 -## cd $WEBKIT -## ./autogen.sh -## ./configure --prefix=$PREFIX -## make -## make install -## fi -## fi -## -## cd $BUILHOME - -# export CD_REL=d704525ebe1c6d08 -# if ! [[ -e Canvas_Draw-$CD_REL.zip ]]; then -# wget http://www.kiatoa.com/matt/iup/Canvas_Draw-$CD_REL.zip -# fi -# -# unzip -o Canvas_Draw-$CD_REL.zip -# -# cd "Canvas Draw-$CD_REL/chicken" -# CSC_OPTIONS="-I$PREFIX/include -L$LIBPATH" $CHICKEN_INSTALL $PROX -D no-library-checks - echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh echo file can be found in the current directory which should work for setting up to run chicken4x echo Testing iup $PREFIX/bin/csi -b -eval '(use iup)(print "Success")' + + ADDED utils/viewscreen Index: utils/viewscreen ================================================================== --- /dev/null +++ utils/viewscreen @@ -0,0 +1,19 @@ +#!/bin/bash + +if ! type screen &> /dev/null;then + xterm -geometry 180x20 -e "$*;echo Press any key to continue;bash -c 'read -n 1 -s'" & + exit +fi + +if [[ $(screen -list | egrep 'Attached|Detached'|awk '{print $1}') == "" ]];then + # echo "No screen found for displaying to. Run \"screen\" in an xterm" + # exit 1 + xterm -e screen -e^ff & + sleep 1 + screen -X hardstatus off + screen -X hardstatus alwayslastline + screen -X hardstatus string '%{= kG}[ %{G}%H %{g}][%= %{= kw}%?%-Lw%?%{r}(%{W}%n*%f%t%?(%u)%?%{r})%{w}%?%+Lw%?%?%= %{g}][%{B} %m-%d %{W} %c %{g}]' +fi + +cmd="cd $PWD;$*" +screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f to see other windows\";bash -c 'read -n 1 -s'" & Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -368,15 +368,23 @@ (arithmetic-shift a 24) (arithmetic-shift r 16) (arithmetic-shift g 8) b)) +;; Obsolete function +;; (define (vg:generate-color) (vg:rgb->number (random 255) (random 255) (random 255))) - ;;(vg:rgb->number 0 0 0)) + +;; Need to return a string of random iup-color for graph +;; +(define (vg:generate-color-rgb) + (conc (number->string (random 255)) " " + (number->string (random 255)) " " + (number->string (random 255)))) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) ;;======================================================================