ADDED .fossil-settings/crnl-glob Index: .fossil-settings/crnl-glob ================================================================== --- /dev/null +++ .fossil-settings/crnl-glob @@ -0,0 +1,1 @@ +docs/manual/megatest_manual.html Index: .mtutil.scm ================================================================== --- .mtutil.scm +++ .mtutil.scm @@ -23,45 +23,46 @@ (define (str-first-char->number str) (char->integer (string-ref str 0))) ;; example of how to set up and write target mappers ;; -(hash-table-set! *target-mappers* - 'prefix-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc contour "/" target))) -(hash-table-set! *target-mappers* - 'prefix-area-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc area "/" contour "/" target))) - -(hash-table-set! *runname-mappers* - 'corporate-ww - (lambda (target run-name area area-path reason contour mode-patt) - (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) - (let* ((last-name (get-last-runname area-path target)) - (last-letter (let* ((ch (if (string? last-name) - (let ((len (string-length last-name))) - (substring last-name (- len 1) len)) - "a")) - (chnum (str-first-char->number ch)) - (a (str-first-char->number "a")) - (z (str-first-char->number "z"))) - (if (and (>= chnum a)(<= chnum z)) - chnum - #f))) - (next-letter (if last-letter - (list->string - (list - (integer->char - (+ last-letter 1)))) ;; surely there is an easier way? - "a"))) - ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) - (conc (seconds->wwdate (current-seconds)) next-letter)))) - -(hash-table-set! *runname-mappers* - 'auto - (lambda (target run-name area area-path reason contour mode-patt) - "auto-eh")) - -;; (print "Got here!") +(add-target-mapper 'prefix-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc contour "/" target))) +(add-target-mapper 'prefix-area-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc area "/" contour "/" target))) + +(add-runname-mapper 'corporate-ww + (lambda (target run-name area area-path reason contour mode-patt) + (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) + (let* ((last-name (get-last-runname area-path target)) + (last-letter (let* ((ch (if (string? last-name) + (let ((len (string-length last-name))) + (substring last-name (- len 1) len)) + "a")) + (chnum (str-first-char->number ch)) + (a (str-first-char->number "a")) + (z (str-first-char->number "z"))) + (if (and (>= chnum a)(<= chnum z)) + chnum + #f))) + (next-letter (if last-letter + (list->string + (list + (integer->char + (+ last-letter 1)))) ;; surely there is an easier way? + "a"))) + ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) + (conc (seconds->wwdate (current-seconds)) next-letter)))) + +(add-runname-mapper 'auto + (lambda (target run-name area area-path reason contour mode-patt) + "auto-eh")) + +;; run only areas where first letter of area name is "a" +;; +(add-area-checker 'first-letter-a + (lambda (area target contour) + (string-match "^a.*$" area))) + Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,20 +1,23 @@ # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less - +SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - http-transport.scm filedb.scm \ - client.scm synchash.scm daemon.scm mt.scm \ + http-transport.scm filedb.scm tdb.scm \ + client.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm tdb.scm rpc-transport.scm \ + rmt.scm api.scm subrun.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm + +# module source files +MSRCFILES = ftail.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ @@ -23,10 +26,16 @@ GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) +MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) + +mofiles/%.o : %.scm + mkdir -p mofiles + csc $(CSCOPTS) -J -c $< -o mofiles/$*.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}') @@ -33,37 +42,77 @@ 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 if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut -mtest: $(OFILES) readline-fix.scm megatest.o - csc $(CSCOPTS) $(OFILES) megatest.o -o mtest +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o + csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest -dboard : $(OFILES) $(GOFILES) dashboard.scm - csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard +dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -mtut: $(OFILES) mtut.scm +mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut +TCMTOBJS = \ + api.o \ + archive.o \ + cgisetup/models/pgdb.o \ + client.o \ + common.o \ + configf.o \ + daemon.o \ + db.o \ + env.o \ + http-transport.o \ + items.o \ + keys.o \ + launch.o \ + lock-queue.o \ + margs.o \ + mt.o \ + megatest-version.o \ + ods.o \ + portlogger.o \ + process.o \ + rmt.o \ + rpc-transport.o \ + runconfig.o \ + runs.o \ + server.o \ + tasks.o \ + tdb.o \ + tests.o \ + subrun.o \ + + +tcmt : $(TCMTOBJS) tcmt.scm + csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt + # 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 +js : java-script-lib/jquery-3.1.0.slim.min.js + mkdir -p $(PREFIX)/share/js + cp java-script-lib/jquery-3.1.0.slim.min.js $(PREFIX)/share/js/jquery-3.1.0.slim.min.js + $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql #multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) @@ -111,13 +160,23 @@ chmod a+x $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut +install-mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/mtut + $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil + +$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt + $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt + +$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper + utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt + chmod a+x $(PREFIX)/bin/tcmt # $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard # $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard # $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper @@ -192,12 +251,17 @@ $(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/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ - $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard + $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + js +# $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib @@ -272,15 +336,23 @@ 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 + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + 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 + srfi-1 posix regex regex-case srfi-69 # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" @@ -304,5 +376,22 @@ 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 +# create a pdf dot graphviz diagram from notations in rmt.scm +rmt.pdf : rmt.scm + grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf + +buildmanual: + cd docs/manual && make + +wikipage=plan +editwiki: + cd docs/manual && ../../utils/editwiki $(wikipage) + +viewmanual: + arora docs/manual/megatest_manual.html + +targets: + @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' + Index: Makefile.deploy ================================================================== --- Makefile.deploy +++ Makefile.deploy @@ -1,29 +1,41 @@ # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= -deploy INSTALL=install +CHICKEN=$(shell which csc) +CHICKEN_BIN_DIR=$(shell dirname ${CHICKEN}/) +CHICKEN_DIR=${CHICKEN_BIN_DIR}/.. 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 \ + http-transport.scm filedb.scm tdb.scm \ + client.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 + rmt.scm api.scm subrun.scm \ + portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm + +# module source files +MSRCFILES = ftail.scm # Eggs to install (straightforward ones) -EGGS=crypt matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) + +MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) + +mofiles/%.o : %.scm + mkdir -p mofiles + csc $(CSCOPTS) -J -c $< -o mofiles/$*.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}') @@ -42,31 +54,46 @@ IMVER=3.11 IUPVER=3.17 KTYPE=26g4 CDVER=5.10 -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard eggs sqlite matt iup +all : $(PREFIX)/bin/.$(ARCHSTR) postgres nanomsg mtest dboard mtut eggs sqlite matt iup wrappers -mtest: $(OFILES) readline-fix.scm megatest.o +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o mkdir -p $(PREFIX)/deploy - csc $(CSCOPTS) $(OFILES) megatest.o -o $(PREFIX)/deploy/mtest + csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/chicken.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/foreign.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/ports.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/data-structures.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/posix.import.so $(PREFIX)/deploy/mtest + cp $(CKPATH)/lib/chicken/7/irregex.import.so $(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 + chicken-install -deploy -p $(PREFIX)/deploy/mtest base64 format regex-case simple-exceptions typed-records apropos directory-utils 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:0.10.2 z3 sql-de-lite hostinfo rpc directory-utils spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables rpc fmt md5:3.1.0 check-errors:1.13.0 string-utils:1.2.4 message-digest:3.1.1 csv-xml:0.10.2 sha1 ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19:3.3.6 readline trace lolevel + cd utils/opensrc/mutils && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd ducttape && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cp $(CHICKEN_DIR)/lib/chicken/7/chicken.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/foreign* $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/ports.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/data-structures.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/posix.import.so $(PREFIX)/deploy/mtest/ + cp $(CHICKEN_DIR)/lib/chicken/7/irregex.import.so $(PREFIX)/deploy/mtest/ + 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 && ./configure --prefix=$(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 + CSC_OPTIONS='-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/' chicken-install -deploy -p $(PREFIX)/deploy/mtest sqlite3 check-errors:1.13.0 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' @@ -82,10 +109,39 @@ 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 + cd opensrc/pkts && chicken-install -deploy -p $(PREFIX)/deploy/mtest + +nanomsg: $(PREFIX)/deploy/mtest/libnanomsg.so.1.0.0 + +$(PREFIX)/deploy/mtest/libnanomsg.so.1.0.0: + 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)/deploy/mtest + cd nanomsg-1.0.0 && make + cd nanomsg-1.0.0 && make install + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/lib -L$(PREFIX)/deploy/mtest/lib64/" chicken-install -deploy -p $(PREFIX)/deploy/mtest nanomsg + +$(PREFIX)/deploy/mtest/bin/pg_config: + wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz + tar xfz postgresql-9.6.4.tar.gz + cd postgresql-9.6.4 && ./configure --prefix=$(PREFIX)/deploy/mtest/ --with-openssl; + cd postgresql-9.6.4 && make + cd postgresql-9.6.4 && make install + +$(PREFIX)/deploy/mtest/postgresql.so: + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/lib -L$(PREFIX)/deploy/mtest/lib64/" chicken-install -deploy -p $(PREFIX)/deploy/mtest postgresql + +postgres: $(PREFIX)/deploy/mtest/bin/pg_config $(PREFIX)/deploy/mtest/postgresql.so + +ducttape: $(PREFIX)/deploy/mtest/ducttape.so + +$(PREFIX)/deploy/mtest/ducttape.so: + cd ducttape && chicken-install -p $(PREFIX)/deploy/mtest -deploy 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 @@ -95,31 +151,42 @@ 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 && ./configure --prefix=$(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 + CSC_OPTIONS="-I$(PREFIX)/include -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)/include -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 +dboard: $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -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 +mtut : $(OFILES) megatest-fossil-hash.scm mtut.scm + csc $(CSCOPTS) $(OFILES) mtut.scm -o $(PREFIX)/deploy/mtest/mtut + # 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 +js : java-script-lib/jquery-3.1.0.slim.min.js + mkdir -p $(PREFIX)/share/js + cp java-script-lib/jquery-3.1.0.slim.min.js $(PREFIX)/share/js/jquery-3.1.0.slim.min.js + +$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql + mkdir -p $(PREFIX)/share/db + $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql + #multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) # csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard # # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm @@ -155,10 +222,20 @@ utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest $(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut + +install-mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/mtut + +$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper + utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil + chmod a+x $(PREFIX)/bin/mtutil $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard @@ -203,10 +280,15 @@ $(PREFIX)/bin/loadrunner : utils/loadrunner $(INSTALL) $< $@ chmod a+x $@ +$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm + make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) + +mtest-reaper: $(PREFIX)/bin/mtest-reaper + # $(PREFIX)/bin/refdb : refdb # $(INSTALL) $< $@ # chmod a+x $@ deploytarg/nbfake : utils/nbfake @@ -226,16 +308,21 @@ 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)/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/remrun \ + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ + $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + js + $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm ext-tests/.fslckout : $(MTQA_FOSSIL) @@ -262,19 +349,21 @@ $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+X $@ deploytarg/apropos.so : Makefile - chicken-install -p deploytarg -deploy -keep-installed $(EGGS) - + for egg in $(EGGS); do \ + echo "chicken-install -p deploytarg -deploy -keep-installed $$egg "; \ + chicken-install -p deploytarg -deploy -keep-installed $$egg ; \ + done # 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 +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so # deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so # for i in iup im cd av call sqlite; do \ # cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ # done @@ -331,11 +420,24 @@ 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 +# 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 + +# create a pdf dot graphviz diagram from notations in rmt.scm +rmt.pdf : rmt.scm + grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf + +wrappers: wrappers/cfg.sh wrappers/megatest wrappers/dashboard + mkdir $(PREFIX)/deploy/mtest/.$(ARCHSTR) -p + cat wrappers/cfg.sh | sed 's#PREFIX#$(PREFIX)\/deploy\/mtest#g' > $(PREFIX)/deploy/mtest/.$(ARCHSTR)/cfg.sh + cat wrappers/megatest | sed 's#PREFIX#$(PREFIX)\/deploy\/mtest#g' | sed 's#ARCHSTR#.$(ARCHSTR)#g' > $(PREFIX)/deploy/mtest/megatest + cat wrappers/dashboard | sed 's#PREFIX#$(PREFIX)\/deploy\/mtest#g'| sed 's#ARCHSTR#.$(ARCHSTR)#g' > $(PREFIX)/deploy/mtest/dashboard + chmod +x $(PREFIX)/deploy/mtest/megatest + chmod +x $(PREFIX)/deploy/mtest/dashboard + Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -23,10 +23,12 @@ get-var get-keys get-key-vals test-toplevel-num-items get-test-info-by-id + get-steps-info-by-id + get-data-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record @@ -39,32 +41,38 @@ get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status get-run-stats + get-run-times get-targets get-target ;; register-run get-tests-tags + get-test-times get-tests-for-run get-test-id get-tests-for-runs-mindata + get-tests-for-run-mindata get-run-name-from-id get-runs + simple-get-runs get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data + read-test-data* login tasks-get-last testmeta-get-record have-incompletes? synchash-get + get-changed-record-ids )) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start @@ -126,10 +134,11 @@ (cond ((not (vector? dat)) ;; it is an error to not receive a vector (vector #f (vector #f "remote must be called with a vector"))) ((> *api-process-request-count* 20) ;; 20) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") + (set! *server-overloaded* #t) (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! (else (let* ((cmd-in (vector-ref dat 0)) (cmd (if (symbol? cmd-in) cmd-in @@ -152,11 +161,26 @@ ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; TESTS - ((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) @@ -193,10 +217,16 @@ ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) + ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) @@ -232,35 +262,42 @@ ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((synchash-get) (apply synchash:server-get dbstruct params)) ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + ((get-test-times) (apply db:get-test-times dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) + ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) + ((get-run-times) (apply db:get-run-times dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) + ((read-test-data*) (apply db:read-test-data* dbstruct params)) + ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -7,12 +7,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest srfi-18) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) (declare (unit archive)) (declare (uses db)) (declare (uses common)) @@ -30,11 +29,11 @@ (flavor 'plain) ;; type of machine to run jobs on (maxload 1.5) ;; max allowed load for this work (adisks (archive:get-archive-disks))) ;; get testdir size ;; - hand off du to job mgr - (if (and (file-exists? testdir) + (if (and (common:file-exists? testdir) (file-is-writable? testdir)) (let* ((dused (jobrunner:run-job flavor ;; machine type maxload ;; max allowed load '() ;; prevars - environment vars to set for the job @@ -137,11 +136,11 @@ (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (mutex-lock! rp-mutex) - (test-physical-path (if (file-exists? test-path) + (test-physical-path (if (common:file-exists? test-path) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f)) (test-base (if (and partial-path-index @@ -152,11 +151,11 @@ #f))) (cond (toplevel/children (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) - ((not (file-exists? test-path)) + ((not (common:file-exists? test-path)) (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else (debug:print 0 *default-log-port* "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" @@ -180,13 +179,13 @@ (conc "-" compress) ;; or (conc "--compress=" compress) "-n" (conc (common:get-testsuite-name) "-" run-id) (conc "--strip-path=" disk-group)) test-paths)) (print-prefix #f)) ;; "Running: ")) ;; change to #f to turn off printing - (if (not (file-exists? archive-dir)) + (if (not (common:file-exists? archive-dir)) (create-directory archive-dir #t)) - (if (not (file-exists? (conc archive-dir "/HEAD"))) + (if (not (common:file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually (debug:print-info 0 *default-log-port* "Init bup in " archive-dir) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix) @@ -233,11 +232,11 @@ (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory (mutex-lock! rp-mutex) - (prev-test-physical-path (if (file-exists? test-path) + (prev-test-physical-path (if (common:file-exists? test-path) ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) @@ -250,11 +249,11 @@ ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children ;; (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path - (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? + (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) DELETED batchsim/Makefile Index: batchsim/Makefile ================================================================== --- batchsim/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -RUN=default.scm - -all : batchsim - ./batchsim $(RUN) - -batchsim : batchsim.scm - csc batchsim.scm - DELETED batchsim/batchsim.scm Index: batchsim/batchsim.scm ================================================================== --- batchsim/batchsim.scm +++ /dev/null @@ -1,417 +0,0 @@ -(use ezxdisp srfi-18) - -(define *ezx* (ezx-init 650 650 "Batch simulator")) -(require-library ezxgui) -(define *green* (make-ezx-color 0 1 0)) -(define *black* (make-ezx-color 0 0 0)) -(define *grey* (make-ezx-color 0.1 0.1 0.1)) -(define *blue* (make-ezx-color 0 0 1)) -(define *cyan* (make-ezx-color 0 1 1)) -(define *green* (make-ezx-color 0 1 0)) -(define *purple* (make-ezx-color 1 0 1)) -(define *red* (make-ezx-color 1 0 0)) -(define *white* (make-ezx-color 1 1 1)) -(define *yellow* (make-ezx-color 1 1 0)) - -(define *user-colors-palette* - (list - *green* - *blue* - *cyan* - *purple* - *red* - *yellow* - *black*)) - -(define *dark-green* (get-color "dark-green")) -(define *brown* (get-color "brown")) - -(ezx-select-layer *ezx* 1) -(ezx-wipe-layer *ezx* 1) - -;; (ezx-str-2d *ezx* 30 30 "Hello" *white*) -;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*) -(ezx-redraw *ezx*) - -(define *last-draw* (current-milliseconds)) -(define *draw-delta* 40) ;; milliseconds between drawing - -(define (wait-for-next-draw-time) - (let* ((cm (current-milliseconds)) - (delta (- *draw-delta* (- cm *last-draw*)))) - (if (> delta 0) - (thread-sleep! (/ delta 1000))) - (set! *last-draw* (current-milliseconds)))) - -(include "events.scm") - -;; System spec (to be moved into loaded file) -;; -;; x y w gap x-min x-max -(define *cpu-grid* (vector 500 50 15 2 500 600)) -(define (make-cpu:grid)(make-vector 6)) -(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... ) -(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc) -(define *obj-locations* (make-hash-table)) ;; name -> (x y layer) -(define *queue-spec* - (vector - 80 ;; start-x - 300 ;; start-y - 300 ;; delta-y how far to next queue - 15 ;; height - 400 ;; length - )) -(define *use-log* #f) -(define *job-log-scale* 10) - -;;====================================================================== -;; CPU -;;====================================================================== - -(define-record cpu name num-cores mem job x y) - -;;====================================================================== -;; CPU Pool -;;====================================================================== - -(define-record pool name x y w h gap boxw cpus delta nrows ncols cpunum) - -(define (new-pool name x y nrows ncols gap boxw) - (let* ((delta (+ gap boxw)) - ;; (nrows (quotient h (+ gap delta))) - ;; (ncols (quotient w (+ gap delta))) - (w (+ gap (* nrows delta))) - (h (+ gap (* ncols delta))) - (cpus (make-vector (* nrows ncols) #f)) - (npool (make-pool name x y w h gap boxw cpus delta nrows ncols 0))) - npool)) - -(define (pool:add-cpu pool name num-cores mem) - (let* ((cpu (make-cpu name num-cores mem #f #f #f))) - (vector-set! (pool-cpus pool)(pool-cpunum pool) cpu) - (pool-cpunum-set! pool (+ 1 (pool-cpunum pool))) - cpu)) - -(define (pool:draw ezx pool) - (let ((nrows (pool-nrows pool)) - (ncols (pool-ncols pool)) - (x (pool-x pool)) - (y (pool-y pool)) - (w (pool-w pool)) - (h (pool-h pool)) - (gap (pool-gap pool)) - (boxw (pool-boxw pool)) - (delta (pool-delta pool)) - (cpus (pool-cpus pool))) - (ezx-select-layer ezx 1) - ;(ezx-wipe-layer ezx 1) - ;; draw time at upper right - (ezx-str-2d ezx x y (pool-name pool) *black*) - (ezx-rect-2d ezx x y (+ x w)(+ y h) *black* 1) - (let loop ((row 0) - (col 0) - (cpunum 0)) - (let* ((cpu (vector-ref cpus cpunum)) - (xval (+ x gap (* row delta))) - (yval (+ y gap (* col delta)))) - (if cpu - (begin - (cpu-x-set! cpu xval) - (cpu-y-set! cpu yval)) - (vector-set! cpus cpunum (make-cpu (conc cpunum) 1 1 #f xval yval))) - ;; (print "box at " xval ", " yval) - (ezx-rect-2d ezx xval yval (+ xval boxw) (+ yval boxw) *grey* 1) - (if (< col (- ncols 1)) - (loop row (+ col 1)(+ cpunum 1)) - (if (< row (- nrows 1)) - (loop (+ row 1) 0 (+ cpunum 1)))))) - (ezx-redraw ezx))) - - -;;====================================================================== -;; Users -;;====================================================================== - -(define *user-colors* (make-hash-table)) - -(define (get-user-color user) - (let ((color (hash-table-ref/default *user-colors* user #f))) - (if color - color - (let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1)) - (color (list-ref *user-colors-palette* color-num))) - (hash-table-set! *user-colors* user color) - color)))) - -;;====================================================================== -;; Job Queues -;;====================================================================== - -;; jobs - -(define (make-queue:job)(make-vector 4)) -(define-inline (queue:job-get-user vec) (vector-ref vec 0)) -(define-inline (queue:job-get-duration vec) (vector-ref vec 1)) -(define-inline (queue:job-get-num-cpu vec) (vector-ref vec 2)) -(define-inline (queue:job-get-num-gigs vec) (vector-ref vec 3)) -(define-inline (queue:job-set-user! vec val)(vector-set! vec 0 val)) -(define-inline (queue:job-set-duration! vec val)(vector-set! vec 1 val)) -(define-inline (queue:job-set-num-cpu! vec val)(vector-set! vec 2 val)) -(define-inline (queue:job-set-num-gigs! vec val)(vector-set! vec 3 val)) - -;; add a job to the queue -;; -(define (add-job queue-name user duration num-cpu num-gigs) - (let* ((queue-dat (hash-table-ref/default *queues* queue-name '())) - (new-queue (append - queue-dat - (list (vector user duration num-cpu num-gigs))))) - (hash-table-set! *queues* queue-name new-queue) - (draw-queue-jobs queue-name))) - -;; peek for jobs to do in queue -;; -(define (peek-job queue-name) - (let ((queue (hash-table-ref/default *queues* queue-name '()))) - (if (null? queue) - #f - (car queue)))) - -;; take job from queue -;; -(define (take-job queue-name) - (let ((queue (hash-table-ref/default *queues* queue-name '()))) - (if (null? queue) - #f - (begin - (hash-table-set! *queues* queue-name (cdr queue)) - (draw-queue-jobs queue-name) - (car queue))))) - -;;====================================================================== -;; CPUs -;;====================================================================== - -(define (make-cpu:dat)(make-vector 6 #f)) -(define-inline (cpu:dat-get-user vec) (vector-ref vec 0)) -(define-inline (cpu:dat-get-job-len vec) (vector-ref vec 1)) -(define-inline (cpu:dat-get-num-cpu vec) (vector-ref vec 2)) -(define-inline (cpu:dat-get-mem vec) (vector-ref vec 3)) -(define-inline (cpu:dat-get-x vec) (vector-ref vec 4)) -(define-inline (cpu:dat-get-y vec) (vector-ref vec 5)) -(define-inline (cpu:dat-set-user! vec val)(vector-set! vec 0 val)) -(define-inline (cpu:dat-set-job-len! vec val)(vector-set! vec 1 val)) -(define-inline (cpu:dat-set-num-cpu! vec val)(vector-set! vec 2 val)) -(define-inline (cpu:dat-set-mem! vec val)(vector-set! vec 3 val)) -(define-inline (cpu:dat-set-x! vec val)(vector-set! vec 4 val)) -(define-inline (cpu:dat-set-y! vec val)(vector-set! vec 5 val)) - -(define-inline (cpu:grid-get-x vec) (vector-ref vec 0)) -(define-inline (cpu:grid-get-y vec) (vector-ref vec 1)) -(define-inline (cpu:grid-get-w vec) (vector-ref vec 2)) -(define-inline (cpu:grid-get-gap vec) (vector-ref vec 3)) -(define-inline (cpu:grid-get-x-min vec) (vector-ref vec 4)) -(define-inline (cpu:grid-get-x-max vec) (vector-ref vec 5)) -(define-inline (cpu:grid-set-x! vec val)(vector-set! vec 0 val)) -(define-inline (cpu:grid-set-y! vec val)(vector-set! vec 1 val)) -(define-inline (cpu:grid-set-w! vec val)(vector-set! vec 2 val)) -(define-inline (cpu:grid-set-gap! vec val)(vector-set! vec 3 val)) -(define-inline (cpu:grid-set-x-min! vec val)(vector-set! vec 4 val)) -(define-inline (cpu:grid-set-x-max! vec val)(vector-set! vec 5 val)) - -(define (add-cpu name num-cores mem) - (let ((x (cpu:grid-get-x *cpu-grid*)) - (y (cpu:grid-get-y *cpu-grid*)) - (delta (+ (cpu:grid-get-w *cpu-grid*)(cpu:grid-get-gap *cpu-grid*))) - (x-max (cpu:grid-get-x-max *cpu-grid*))) - (hash-table-set! *cpus* name (vector #f #f num-cores mem x y)) - (if (> x x-max) - (begin - (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*)) - (cpu:grid-set-y! *cpu-grid* (+ y delta))) - (cpu:grid-set-x! *cpu-grid* (+ x delta))))) - -;; draw grey box for each cpu on layer 2 -;; jobs are drawn on layer 1 -;; -(define (draw-cpus) ;; call once after init'ing all cpus - (ezx-select-layer *ezx* 1) - (ezx-wipe-layer *ezx* 1) - ;; draw time at upper right - (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*) - (for-each - (lambda (cpu) - (let ((x (cpu:dat-get-x cpu)) - (y (cpu:dat-get-y cpu)) - (w (cpu:grid-get-w *cpu-grid*))) - (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1))) - (hash-table-values *cpus*)) - (ezx-redraw *ezx*)) - -(define (draw-jobs) - ;; (draw-cpus) - (ezx-select-layer *ezx* 2) - (ezx-wipe-layer *ezx* 2) - (for-each - (lambda (cpu) - (let* ((x (cpu:dat-get-x cpu)) - (y (cpu:dat-get-y cpu)) - (w (cpu:grid-get-w *cpu-grid*)) - (u (cpu:dat-get-user cpu))) - (if u ;; job running if not #f - (let ((color (get-user-color u))) - (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color))))) - (hash-table-values *cpus*)) - (ezx-redraw *ezx*)) - -(define (end-job cpu-name user) - (let ((cpu (hash-table-ref/default *cpus* cpu-name #f))) - (if cpu - (let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error - (if (or (not curr-user) - (not (equal? curr-user user))) - (print "ERROR: cpu " cpu-name " not running job for " user "!") - (begin - (cpu:dat-set-user! cpu #f) - (cpu:dat-set-job-len! cpu #f) - (draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat)))) - (print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it.")))) - -(define (run-job cpu-name job) - (let* ((user (queue:job-get-user job)) - (job-len (queue:job-get-duration job)) - (cpu (hash-table-ref/default *cpus* cpu-name #f))) - (if cpu - (let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error - (if curr-user - (begin - (print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name) - #f) - (begin - (cpu:dat-set-user! cpu user) - (cpu:dat-set-job-len! cpu job-len) - (draw-jobs) - (hash-table-set! *cpus* cpu-name cpu) - (event (+ *now* job-len) (lambda ()(end-job cpu-name user))) - #t))) - #f))) - -(define (get-cpu) - (let ((all-cpus (hash-table-keys *cpus*))) - (if (null? all-cpus) - #f - (let loop ((hed (car all-cpus)) - (tal (cdr all-cpus))) - (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available - (if (null? tal) - #f - (loop (car tal)(cdr tal))) - hed))))) - -;;====================================================================== -;; Animation -;;====================================================================== - -;; make-vector-record queue spec x y delta-y height length -(define (make-queue:spec)(make-vector 5)) -(define-inline (queue:spec-get-x vec) (vector-ref vec 0)) -(define-inline (queue:spec-get-y vec) (vector-ref vec 1)) -(define-inline (queue:spec-get-delta-y vec) (vector-ref vec 2)) -(define-inline (queue:spec-get-height vec) (vector-ref vec 3)) -(define-inline (queue:spec-get-length vec) (vector-ref vec 4)) -(define-inline (queue:spec-set-x! vec val)(vector-set! vec 0 val)) -(define-inline (queue:spec-set-y! vec val)(vector-set! vec 1 val)) -(define-inline (queue:spec-set-delta-y! vec val)(vector-set! vec 2 val)) -(define-inline (queue:spec-set-height! vec val)(vector-set! vec 3 val)) -(define-inline (queue:spec-set-length! vec val)(vector-set! vec 4 val)) - -;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer -;; -(define (draw-queues) - (let* ((text-offset 3) - (queue-names (sort (hash-table-keys *queues*) string>=?)) - (start-x (vector-ref *queue-spec* 0)) - (text-x (+ start-x text-offset)) - (delta-y (vector-ref *queue-spec* 1)) - (delta-x (vector-ref *queue-spec* 2)) - (height (vector-ref *queue-spec* 3)) - (length (vector-ref *queue-spec* 4)) - (end-x (+ start-x length))) - (ezx-select-layer *ezx* 3) - (ezx-wipe-layer *ezx* 3) - (let loop ((y (vector-ref *queue-spec* 1)) - (qname (car queue-names)) - (tail (cdr queue-names)) - (layer 4)) - (print "Drawing queue at x=" start-x ", y=" y) - (ezx-fillrect-2d *ezx* start-x y end-x (+ y height) *brown*) - (ezx-str-2d *ezx* text-x (- (+ y height) text-offset) qname *white*) - (hash-table-set! *obj-locations* qname (list start-x y layer)) - (if (not (null? tail)) - (loop (+ y height delta-y) - (car tail) - (cdr tail) - (+ layer 1)))) - (ezx-redraw *ezx*))) - -;; compress queue data to (vector user count) list -;; -(define (draw-queue-compress-queue-data queue-dat) - (let loop ((hed (car queue-dat)) - (tal (cdr queue-dat)) - (curr #f) ;; (vector name count) - (res '())) - (let ((user (queue:job-get-user hed))) - (cond - ((not curr) ;; first time through only? - (if (null? tal) - (append res (list (vector user 1))) - (loop (car tal)(cdr tal)(vector user 1) res))) - ((equal? (vector-ref curr 0) user) - (vector-set! curr 1 (+ (vector-ref curr 1) 1)) - (if (null? tal) - (append res (list curr)) - (loop (car tal)(cdr tal) curr res))) - (else ;; names are different, add curr to queue and create new curr - (let ((newcurr (vector user 1))) - (if (null? tal) - (append res (list newcurr)) - (loop (car tal)(cdr tal) newcurr (append res (list curr)))))))))) - -;; draw jobs for a given queue -;; -(define (draw-queue-jobs queue-name) - (let* ((queue-dat (hash-table-ref/default *queues* queue-name #f)) ;; list of jobs in the queue - (obj-spec (hash-table-ref/default *obj-locations* queue-name #f))) ;; x, y etc. of the drawn queue - (if obj-spec - (let ((origin-x (list-ref obj-spec 0)) - (origin-y (list-ref obj-spec 1)) - (bar-width 10) - (queue-len (queue:spec-get-length *queue-spec*)) - (layer (list-ref obj-spec 2))) - (ezx-select-layer *ezx* layer) - (ezx-wipe-layer *ezx* layer) - (if (not (null? queue-dat)) - (let ((res (draw-queue-compress-queue-data queue-dat))) - (if (not (null? res)) - (let loop ((hed (car res)) - (tal (cdr res)) - (x2 (+ origin-x queue-len))) - (let* ((user (vector-ref hed 0)) - (h (let ((numjobs (vector-ref hed 1))) - (if *use-log* - (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs))))) - numjobs))) - (x1 (- x2 bar-width)) - (y2 (- origin-y h))) - ;; (print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2) - (ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user)) - (if (not (null? tal)) - (loop (car tal)(cdr tal) x1))))) - (ezx-redraw *ezx*))))))) - -(let* ((args (argv)) - (fname (if (> (length args) 1) - (cadr args) - "default.scm"))) - (load (if (file-exists? fname) fname "default.scm"))) DELETED batchsim/default.scm Index: batchsim/default.scm ================================================================== --- batchsim/default.scm +++ /dev/null @@ -1,133 +0,0 @@ -;; run sim for four hours -;; -(define *end-time* (* 60 50)) - -;; create the cpus -;; -(let loop ((count 200)) - (add-cpu (conc "cpu_" count) 1 1) - (if (>= count 0)(loop (- count 1)))) - -(draw-cpus) - -(define *pool1* (new-pool "generic" 100 100 100 100 2 10)) -(let loop ((count 10)) - (pool:add-cpu *pool1* (conc count) 1 1) - (if (> count 0) - (loop (- count 1)))) - -(pool:draw *ezx* *pool1*) - -;; init the queues -;; -(hash-table-set! *queues* "normal" '()) -(hash-table-set! *queues* "quick" '()) -(draw-queues) - -;; user k adds 200 jobs at time zero -;; -(event *start-time* - (lambda () - (let loop ((count 300)) ;; add 500 jobs - (add-job "normal" "k" 600 1 1) - (if (>= count 0)(loop (- count 1)))))) - -;; one minute in user m runs ten jobs -;; -(event (+ 600 *start-time*) - (lambda () - (let loop ((count 300)) ;; add 100 jobs - (add-job "normal" "m" 600 1 1) - (if (> count 0)(loop (- count 1)))))) - -;; every minute user j runs ten jobs -;; -(define *user-j-jobs* 300) -(event (+ 600 *start-time*) - (lambda () - (let f () - (schedule 60) - (if (> *user-j-jobs* 0) - (begin - (let loop ((count 5)) ;; add 100 jobs - (add-job "quick" "j" 600 1 1) - (if (> count 0)(loop (- count 1)))) - (set! *user-j-jobs* (- *user-j-jobs* 5)))) - (if (and (not *done*) - (> *user-j-jobs* 0)) - (f))))) ;; Megatest user running 200 jobs - -;; every minute user j runs ten jobs -;; -(define *user-j-jobs* 300) -(event (+ 630 *start-time*) - (lambda () - (let f () - (schedule 60) - (if (> *user-j-jobs* 0) - (begin - (let loop ((count 5)) ;; add 100 jobs - (add-job "quick" "n" 600 1 1) - (if (> count 0)(loop (- count 1)))) - (set! *user-j-jobs* (- *user-j-jobs* 5)))) - (if (and (not *done*) - (> *user-j-jobs* 0)) - (f))))) ;; Megatest user running 200 jobs - -;; ;; -;; (event *start-time* -;; (lambda () -;; (let f ((count 200)) -;; (schedule 10) -;; (add-job "normal" "t" 60 1 1) -;; (if (and (not *done*) -;; (>= count 0)) -;; (f (- count 1)))))) - -;; every 3 seconds check for available machines and launch a job -;; -(event *start-time* - (lambda () - (let f () - (schedule 3) - (let ((queue-names (random-sort (hash-table-keys *queues*)))) - (let loop ((cpu (get-cpu)) - (count (+ (length queue-names) 4)) - (qname (car queue-names)) - (remq (cdr queue-names))) - (if (and cpu - (> count 0)) - (begin - (if (peek-job qname) ;; any jobs to do in normal queue - (let ((job (take-job qname))) - (run-job cpu job))) - (loop (get-cpu) - (- count 1) - (if (null? remq) - (car queue-names) - (car remq)) - (if (null? remq) - (cdr queue-names) - (cdr remq))))))) - (if (not *done*)(f))))) - -;; screen updates -;; -(event *start-time* (lambda () - (let f () - (schedule 60) ;; update the screen every 60 seconds of sim time - (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*)) - (wait-for-next-draw-time) - (if (not *done*) (f))))) - - -;; end the simulation -;; -(event *end-time* - (lambda () - (set! *event-list* '()) - (set! *done* #t))) - -(start) -;; (exit 0) - DELETED batchsim/events.scm Index: batchsim/events.scm ================================================================== --- batchsim/events.scm +++ /dev/null @@ -1,79 +0,0 @@ - -;;====================================================================== -;; Event Processing and Simulator -;;====================================================================== - -;; The global event list -(define *event-list* '()) -(define *start-time* 0) -(define *end-time* (* 60 60 4)) ;; four hours -(define *now* *start-time*) -(define *done* #f) - -(define (random-sort l) - (sort l - (lambda (x y) - (equal? 0 (random 2))))) - -;; Each item in the event list is a list of a scheduled time and the thunk -;; (time thunk). Sort the list so that the next event is the earliest. -;; -(define event-sort - (lambda (@a @b) - (< (car @a)(car @b)))) - -(define event - (lambda ($time $thunk) ;; add a sort based on scheduled time here -- improve later - ;; to use an insert algorythm. - (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort)))) - -(define start - (lambda () - (let ((next (car *event-list*))) - (set! *event-list* (cdr *event-list*)) - (set! *now* (car next)) - (if (not *done*) ;; note that the second item in the list is the thunk - ((car (cdr next))))))) - -(define pause - (lambda () - (call/cc - (lambda (k) - (event (lambda () (k #f))) - (start))))) - -(define schedule - (lambda ($time) - (call/cc - (lambda (k) - (event (+ *now* $time) (lambda () (k #f))) - (start))))) - -;; (event (lambda () (let f () (pause) (display "h") (f)))) - -(define years->seconds - (lambda ($yrs) - (* $yrs 365 24 3600))) - -(define weeks->seconds - (lambda ($wks) - (* $wks 7 24 3600))) - -(define days->seconds - (lambda ($days) - (* $days 24 3600))) - -(define months->seconds - (lambda ($months) - (* $months (/ 365 12) 24 3600))) - -(define seconds->date - (lambda ($seconds) - (posix-strftime "%D" (posix-localtime (inexact->exact $seconds))))) - -(define (seconds->h:m:s seconds) - (let* ((hours (quotient seconds 3600)) - (rem1 (- seconds (* hours 3600))) - (minutes (quotient rem1 60)) - (rem-sec (- rem1 (* minutes 60)))) - (conc hours "h " minutes "m " rem-sec "s"))) DELETED batchsim/testing.scm Index: batchsim/testing.scm ================================================================== --- batchsim/testing.scm +++ /dev/null @@ -1,135 +0,0 @@ -;; run sim for four hours -;; -(define *end-time* (* 60 50)) - -;; create the cpus -;; -(let loop ((count 200)) - (add-cpu (conc "cpu_" count) 1 1) - (if (>= count 0)(loop (- count 1)))) - -;; (draw-cpus) - -(define *pool1* (new-pool "generic" 20 20 12 80 2 4)) -(let loop ((count 10)) - (pool:add-cpu *pool1* (conc count) 1 1) - (if (> count 0) - (loop (- count 1)))) - -(pool:draw *ezx* *pool1*) - -;; ;; init the queues -;; ;; -;; (hash-table-set! *queues* "normal" '()) -;; (hash-table-set! *queues* "quick" '()) -;; (draw-queues) -;; -;; ;; user k adds 200 jobs at time zero -;; ;; -;; (event *start-time* -;; (lambda () -;; (let loop ((count 300)) ;; add 500 jobs -;; (add-job "normal" "k" 600 1 1) -;; (if (>= count 0)(loop (- count 1)))))) -;; -;; ;; one minute in user m runs ten jobs -;; ;; -;; (event (+ 600 *start-time*) -;; (lambda () -;; (let loop ((count 300)) ;; add 100 jobs -;; (add-job "normal" "m" 600 1 1) -;; (if (> count 0)(loop (- count 1)))))) -;; -;; ;; every minute user j runs ten jobs -;; ;; -;; (define *user-j-jobs* 300) -;; (event (+ 600 *start-time*) -;; (lambda () -;; (let f () -;; (schedule 60) -;; (if (> *user-j-jobs* 0) -;; (begin -;; (let loop ((count 5)) ;; add 100 jobs -;; (add-job "quick" "j" 600 1 1) -;; (if (> count 0)(loop (- count 1)))) -;; (set! *user-j-jobs* (- *user-j-jobs* 5)))) -;; (if (and (not *done*) -;; (> *user-j-jobs* 0)) -;; (f))))) ;; Megatest user running 200 jobs -;; -;; ;; every minute user j runs ten jobs -;; ;; -;; (define *user-j-jobs* 300) -;; (event (+ 630 *start-time*) -;; (lambda () -;; (let f () -;; (schedule 60) -;; (if (> *user-j-jobs* 0) -;; (begin -;; (let loop ((count 5)) ;; add 100 jobs -;; (add-job "quick" "n" 600 1 1) -;; (if (> count 0)(loop (- count 1)))) -;; (set! *user-j-jobs* (- *user-j-jobs* 5)))) -;; (if (and (not *done*) -;; (> *user-j-jobs* 0)) -;; (f))))) ;; Megatest user running 200 jobs -;; -;; ;; ;; -;; ;; (event *start-time* -;; ;; (lambda () -;; ;; (let f ((count 200)) -;; ;; (schedule 10) -;; ;; (add-job "normal" "t" 60 1 1) -;; ;; (if (and (not *done*) -;; ;; (>= count 0)) -;; ;; (f (- count 1)))))) -;; -;; ;; every 3 seconds check for available machines and launch a job -;; ;; -;; (event *start-time* -;; (lambda () -;; (let f () -;; (schedule 3) -;; (let ((queue-names (random-sort (hash-table-keys *queues*)))) -;; (let loop ((cpu (get-cpu)) -;; (count (+ (length queue-names) 4)) -;; (qname (car queue-names)) -;; (remq (cdr queue-names))) -;; (if (and cpu -;; (> count 0)) -;; (begin -;; (if (peek-job qname) ;; any jobs to do in normal queue -;; (let ((job (take-job qname))) -;; (run-job cpu job))) -;; (loop (get-cpu) -;; (- count 1) -;; (if (null? remq) -;; (car queue-names) -;; (car remq)) -;; (if (null? remq) -;; (cdr queue-names) -;; (cdr remq))))))) -;; (if (not *done*)(f))))) -;; -;; ;; screen updates -;; ;; -(event *start-time* (lambda () - (let f () - (schedule 60) ;; update the screen every 60 seconds of sim time - ;; (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*)) - (pool:draw *ezx* *pool1*) - - (wait-for-next-draw-time) - (if (not *done*) (f))))) -;; -;; -;; ;; end the simulation -;; ;; -(event *end-time* - (lambda () - (set! *event-list* '()) - (set! *done* #t))) -;; -(start) -;; ;; (exit 0) -;; Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -90,48 +90,141 @@ (print-call-chain) (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn)) #f) (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec)) (pgdb:get-ttype dbh target-spec))))) + +;;====================================================================== +;; T A G S +;;====================================================================== + + +(define (pgdb:get-tag-info-by-name dbh tag) + (dbi:get-one-row dbh "SELECT id,tag_name FROM tags where tag_name=?;" tag)) + +(define (pgdb:insert-tag dbh name ) + (dbi:exec dbh "INSERT INTO tags (tag_name) VALUES (?)" name )) + +(define (pgdb:insert-area-tag dbh tag-id area-id ) + (dbi:exec dbh "INSERT INTO area_tags (tag_id, area_id) VALUES (?,?)" tag-id area-id )) + +(define (pgdb:is-area-taged dbh area-id) + (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=?;" area-id))) + (if area-tag-id + #t + #f))) + +(define (pgdb:is-area-taged-with-a-tag dbh tag-id area-id) + (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=? and tag_id=?;" area-id tag-id))) + (if area-tag-id + #t + #f))) + ;;====================================================================== ;; R U N S ;;====================================================================== ;; given a target spec id, target and run-name return the run-id ;; if no run found return #f ;; -(define (pgdb:get-run-id dbh spec-id target run-name) - (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;" - spec-id target run-name)) +(define (pgdb:get-run-id dbh spec-id target run-name area-id) + (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=? and area_id=?;" + spec-id target run-name area-id)) ;; given a run-id return all the run info ;; -(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not? +(define (pgdb:get-run-info dbh run-id ) ;; to join ttype or not? (dbi:get-one-row dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id - FROM runs WHERE id=?;" run-id)) + FROM runs WHERE id=? ;" run-id )) ;; refresh the data in a run record ;; -(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count) ;; area-id) +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id) ;; area-id) (dbi:exec dbh "UPDATE runs SET - state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? - WHERE id=?;" - state status owner event-time comment fail-count pass-count run-id)) + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? + WHERE id=? and area_id=?;" + state status owner event-time comment fail-count pass-count run-id area-id)) ;; given all needed info create run record ;; -(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count) +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id) + (dbi:exec + dbh + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id ) + VALUES (?,?,?,?,?,?,?,?,?,?,?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id)) + +;;====================================================================== +;; T E S T - S T E P S +;;====================================================================== + +(define (pgdb:get-test-step-id dbh test-id stepname state) + (dbi:get-one + dbh + "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;" + test-id stepname state)) + +(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile) + (dbi:exec + dbh + "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment) + VALUES (?,?,?,?,?,?,?);" + test-id stepname state status event_time logfile comment)) + +(define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile) + (dbi:exec + dbh + "UPDATE test_steps SET + test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=? + WHERE id=?;" + test-id stepname state status event_time logfile comment step-id)) + + +;;====================================================================== +;; T E S T - D A T A +;;====================================================================== + +(define (pgdb:get-test-data-id dbh test-id category variable) + (dbi:get-one + dbh + "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;" + test-id category variable)) + +(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type) + ; (print "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) + ; VALUES (?,?,?,?,?,?,?,?,?,?) " test-id " " category " " variable " " value " " expected " " tol " " units " " comment " " status " " type) + (if (not (string? units)) + (set! units "" )) + (if (not (string? variable)) + (set! variable "" )) + (if (not (real? value)) + (set! value 0 )) + (if (not (real? expected)) + (set! expected 0 )) +(if (not (real? tol)) + (set! tol 0 )) + + (dbi:exec + dbh + "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) + VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units comment status type)) + +(define (pgdb:update-test-data dbh data-id test-id category variable value expected tol units comment status type) (dbi:exec - dbh - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count) - VALUES (?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count)) + dbh + "UPDATE test_data SET + test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=? + WHERE id=?;" + test-id category variable value expected tol units comment status type data-id )) + + ;;====================================================================== ;; T E S T S ;;====================================================================== Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -10,18 +10,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest matchable) -;; (use zmq) - -(use (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) +(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 + message-digest matchable spiffy uri-common intarweb http-client + spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) (declare (uses common)) (declare (uses db)) ADDED codescanlib.scm Index: codescanlib.scm ================================================================== --- /dev/null +++ codescanlib.scm @@ -0,0 +1,127 @@ + +;; gotta compile with csc, doesn't work with csi -s for whatever reason + +(use srfi-69) +(use matchable) +(use utils) +(use ports) +(use extras) +(use srfi-1) +(use posix) +(use srfi-12) + +;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) ) +(define (load-scm-file scm-file) + ;;(print "load "scm-file) + (handle-exceptions + exn + '() + (with-input-from-string + (conc "(" + (with-input-from-file scm-file read-all) + ")" ) + read))) + +;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file +;; -- be advised: +;; * this may be fooled by macros, since this code does not take them into account. +;; * this code does only checks for form (define ( ... ) ) +;; so it excludes from reckoning +;; - generated functions, as in things like foo-set! from defstructs, +;; - define-inline, ( +;; - define procname (lambda .. +;; - etc... +(define (get-toplevel-procs+file+args+body filename) + (let* ((scm-tree (load-scm-file filename)) + (procs + (filter identity + (map + (match-lambda + [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... + [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... + [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... + [('define (defname args ...) body ...) ;; match (define (procname ) ) + (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) + (list defname filename args body) + #f)] + [else #f] ) scm-tree)))) + procs)) + + +;; given a sexp, return a flat list of atoms in that sexp +(define (get-atoms-in-body body) + (cond + ((null? body) '()) + ((atom? body) (list body)) + (else + (apply append (map get-atoms-in-body body))))) + +;; given a file, return a list of procname, file, list of atoms in said procname +(define (get-procs+file+atoms file) + (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) + (res + (map + (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (args (caddr item)) + (body (cadddr item)) + (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) + (list proc file atoms))) + toplevel-proc-items))) + res)) + +;; uniquify a list of atoms +(define (unique-atoms lst) + (let loop ((lst (flatten lst)) (res '())) + (if (null? lst) + (reverse res) + (let ((c (car lst))) + (loop (cdr lst) (if (member c res) res (cons c res))))))) + +;; given a list of procname, filename, list of procs called from procname, cross reference and reverse +;; returning alist mapping procname to procname that calls said procname +(define (get-callers-alist all-procs+file+calls) + (let* ((all-procs (map car all-procs+file+calls)) + (caller-ht (make-hash-table))) + ;; let's cross reference with a hash table + (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) + (for-each (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (calls (caddr item))) + (for-each (lambda (callee) + (hash-table-set! caller-ht callee + (cons proc + (hash-table-ref caller-ht callee)))) + calls))) + all-procs+file+calls) + (map (lambda (x) + (let ((k (car x)) + (r (unique-atoms (cdr x)))) + (cons k r))) + (hash-table->alist caller-ht)))) + +;; create a handy cross-reference of callees to callers in the form of an alist. +(define (get-xref all-scm-files) + (let* ((all-procs+file+atoms + (apply append (map get-procs+file+atoms all-scm-files))) + (all-procs (map car all-procs+file+atoms)) + (all-procs+file+calls ; proc calls things in calls list + (map (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (atoms (caddr item)) + (calls + (filter identity + (map + (lambda (x) + (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self + (member x all-procs)) + x + #f)) + atoms)))) + (list proc file calls))) + all-procs+file+atoms)) + (callers (get-callers-alist all-procs+file+calls))) + callers)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,23 +7,23 @@ ;; 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 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable) -(require-extension regex posix) - -(require-extension (srfi 18) extras tcp rpc) - -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) +(use srfi-1 data-structures posix regex-case (prefix base64 base64:) + format dot-locking csv-xml z3 ;; sql-de-lite + hostinfo md5 message-digest typed-records directory-utils stack + matchable regex posix (srfi 18) extras ;; tcp + (prefix nanomsg nmsg:) + (prefix sqlite3 sqlite3:) + pkts (prefix dbi dbi:) + ) (declare (unit common)) -(declare (uses keys)) (include "common_records.scm") + ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) @@ -31,10 +31,27 @@ ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) + +;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . +;; arguments - thunk, message +(define (common:fail-safe thunk warning-message-on-exception) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception) + (debug:print-info 0 *default-log-port* + (string-substitute "\n?Error:" "nonfatal condition:" + (with-output-to-string + (lambda () + (print-error-message exn) )))) + (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...") + #f) + (thunk))) + (define getenv get-environment-variable) (define (safe-setenv key val) (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") (if (and (string? val) @@ -46,11 +63,21 @@ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) (define home (getenv "HOME")) (define user (getenv "USER")) -;; GLOBAL GLETCHES + +;; returns list of fd count, socket count +(define (get-file-descriptor-count #!key (pid (current-process-id ))) + (list + (length (glob (conc "/proc/" pid "/fd/*"))) + (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) + ) +) + + +;; GLOBALS ;; CONTEXTS (defstruct cxt (taskdb #f) (cmutex (make-mutex))) @@ -76,10 +103,11 @@ ;; (define *user-hash-data* (make-hash-table)) (define *db-keys* #f) +(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here (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 (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) @@ -90,10 +118,11 @@ (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog +(define *default-area-tag* "local") ;; DATABASE (define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > @@ -111,18 +140,20 @@ (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) +;; no sync db +(define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) -;; (define *server-id* #f) +(define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) @@ -129,10 +160,11 @@ (define *home-host* #f) ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) +(define *server-overloaded* #f) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport @@ -148,18 +180,57 @@ (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) + +;; Miscellaneous +(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers + +(use posix-extras pathname-expand files) + +;; this plugs a hole in posix-extras in recent chicken versions > 4.9) +(let-values (( (chicken-release-number chicken-major-version) + (apply values + (map string->number + (take + (string-split (chicken-version) ".") + 2))))) + (let ((resolve-pathname-broken? + (or (> chicken-release-number 4) + (and (eq? 4 chicken-release-number) (> chicken-major-version 9))))) + (if resolve-pathname-broken? + (define ##sys#expand-home-path pathname-expand)))) + +(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + +(define (common:get-this-exe-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) +(define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) +(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) +(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) + + + + + (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive (conndat #f) (transport *transport-type*) - (server-timeout (server:get-timeout)) ;; default from server:get-timeout + (server-timeout (server:expiration-timeout)) (force-server #f) (ro-mode #f) (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode ;; launching and hosts @@ -225,28 +296,40 @@ (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) +;; postive number if megatest version > db version +;; negative number if megatest version < db version +(define (common:version-db-delta) + (- megatest-version (common:get-last-run-version-number))) + (define (common:version-changed?) (not (equal? (common:get-last-run-version) - (common:version-signature)))) + (common:version-signature)))) +(define (common:api-changed?) + (not (equal? (substring (->string megatest-version) 0 4) + (substring (conc (common:get-last-run-version)) 0 4)))) + ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; -(define (common:cleanup-db dbstruct) - (db:multi-db-sync +(define (common:cleanup-db dbstruct #!key (full #f)) + (apply db:multi-db-sync dbstruct + 'schema ;; 'new2old 'killservers - 'dejunk - ;; 'adj-testids + 'adj-target ;; 'old2new 'new2old - 'schema) - (if (common:version-changed?) + ;; (if full + '(dejunk) + ;; '()) + ) + (if (common:api-changed?) (common:set-last-run-version))) ;; Rotate logs, logic: ;; if > 500k and older than 1 week: ;; remove previous compressed log and compress this log @@ -266,11 +349,11 @@ (> (file-size fullname) 200000)) (and (string-match "^server-.*.log" file) (> (- (current-seconds) (file-modification-time fullname)) (* 8 60 60)))) (let ((gzfile (conc fullname ".gz"))) - (if (file-exists? gzfile) + (if (common:file-exists? gzfile) (begin (debug:print-info 0 *default-log-port* "removing " gzfile) (delete-file gzfile))) (debug:print-info 0 *default-log-port* "compressing " file) (system (conc "gzip " fullname))) @@ -285,22 +368,22 @@ ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) (if (common:on-homehost?) - (if (common:version-changed?) + (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) (read-only (not (file-write-access? dbfile))) - (dbstruct (db:setup))) + (dbstruct (db:setup #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (cond ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) - ((and (file-exists? mtconf) (file-exists? dbfile) (not read-only) + ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only) (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") (handle-exceptions exn (begin @@ -307,14 +390,14 @@ (debug:print 0 *default-log-port* "Failed to switch versions.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) (exit 1)) (common:cleanup-db dbstruct))) - ((not (file-exists? mtconf)) + ((not (common:file-exists? mtconf)) (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) - ((not (file-exists? dbfile)) + ((not (common:file-exists? dbfile)) (debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (eq? (current-user-id)(file-owner mtconf))) (debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.") (exit 1)) @@ -321,14 +404,14 @@ (read-only (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") (exit 1)) (else (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") - (exit 1))))) - (begin - (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") - (exit 1)))) + (exit 1))))))) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") +;; (exit 1)))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== @@ -390,10 +473,13 @@ (map common:to-alist (hash-table->alist dat))) (else (if dat dat "")))) + +(define (common:alist-ref/default key alist default) + (or (alist-ref key alist) default)) (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default *common:denoise* key 0)) (currtime (current-seconds))) @@ -424,11 +510,11 @@ ;; (define (common:simple-file-lock fname #!key (expire-time 300)) (handle-exceptions exn #f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail. - (if (file-exists? fname) + (if (common:file-exists? fname) (if (> (- (current-seconds)(file-modification-time fname)) expire-time) (begin (delete-file* fname) (common:simple-file-lock fname expire-time: expire-time)) #f) @@ -435,11 +521,11 @@ (let ((key-string (conc (get-host-name) "-" (current-process-id)))) (with-output-to-file fname (lambda () (print key-string))) (thread-sleep! 0.25) - (if (file-exists? fname) + (if (common:file-exists? fname) (with-input-from-file fname (lambda () (equal? key-string (read-line)))) #f))))) @@ -462,12 +548,14 @@ ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== -(define *common:std-states* - '((0 "ARCHIVED") +;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls +(define *common:std-states* ;; for toggle buttons in dashboard + '( + (0 "ARCHIVED") (1 "STUCK") (2 "KILLREQ") (3 "KILLED") (4 "NOT_STARTED") (5 "COMPLETED") @@ -474,36 +562,59 @@ (6 "LAUNCHED") (7 "REMOTEHOSTSTART") (8 "RUNNING") )) +(define *common:dont-roll-up-states* + '("DELETED" + "REMOVING" + "CLEANING" + "ARCHIVE_REMOVING" + )) + +;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls +;; note these statuses are sorted from better to worse. +;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items (define *common:std-statuses* - '(;; (0 "DELETED") + '(;; (0 "DELETED") (1 "n/a") (2 "PASS") - (3 "CHECK") - (4 "SKIP") - (5 "WARN") - (6 "WAIVED") + (3 "SKIP") + (4 "WARN") + (5 "WAIVED") + (6 "CHECK") (7 "STUCK/DEAD") - (8 "FAIL") - (9 "ABORT"))) + (8 "DEAD") + (9 "FAIL") + (10 "PREQ_FAIL") + (11 "PREQ_DISCARDED") + (12 "ABORT"))) (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed - '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE")) + '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" )) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD")) +(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed + '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")) + +;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items (define *common:running-states* ;; test is either running or can be run - '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED")) + '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED")) (define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) (define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) + +;; group tests into buckets corresponding to rollup +;;; Running, completed-pass, completed-non-pass + worst status, not started. +;; filter out +;(define (common:categorize-items-for-rollup in-tests) +; ( (define (common:special-sort items order comp) (let ((items-order (map reverse order)) (acomp (or comp >))) (sort items @@ -588,20 +699,26 @@ (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) -(define (common:get-db-tmp-area) +(define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* - (if *toppath* - (let ((dbpath (create-directory (conc "/tmp/" (current-user-name) - "/megatest_localdb/" - (common:get-testsuite-name) "/" - (string-translate *toppath* "/" ".")) #t))) - (set! *db-cache-path* dbpath) - dbpath) + (if *toppath* ;; common:get-create-writeable-dir + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (exit 1)) + (let ((dbpath (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + (common:get-testsuite-name) "/" + (string-translate *toppath* "/" ".")))))) ;; #t)))) + (set! *db-cache-path* dbpath) + dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) @@ -618,23 +735,10 @@ ;; (let ((ohh (common:on-homehost?)) ;; (srv (args:get-arg "-server"))) ;; (and ohh srv))) ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) - -;;;; run-ids -;; if #f use *db-local-sync* : or 'local-sync-flags -;; if #t use timestamps : or 'timestamps -(define (common:sync-to-megatest.db dbstruct) - (let ((start-time (current-seconds)) - (res (db:multi-db-sync dbstruct 'new2old))) - (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) - (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)))) - res)) - (define *wdnum* 0) (define *wdnum*mutex (make-mutex)) @@ -661,102 +765,34 @@ (< duration-since-last-sync sync-cool-off-duration)) (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) (if (not *time-to-exit*) (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) - (if (> golden-mtdb-mtime tmp-mtdb-mtime) - (let ((res (db:multi-db-sync dbstruct 'old2new))) - (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))) + (if (> golden-mtdb-mtime tmp-mtdb-mtime) + (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back + (let ((res (db:multi-db-sync dbstruct 'old2new))) + (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) (loop (current-seconds))) #t))) (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) - - -(define (common:writable-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:run-sync?)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds)) - (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) - (debug:print-info 2 *default-log-port* "Periodic sync thread started.") - (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) - (if (and legacy-sync (not *time-to-exit*)) - (let* (;;(dbstruct (db:setup)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (mtpath (db:dbdat-get-path mtdb))) - (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") - (let loop () - ;; sync for filesystem local db writes - ;; - (mutex-lock! *db-multi-sync-mutex*) - (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write - (sync-in-progress *db-sync-in-progress*) - (should-sync (and (not *time-to-exit*) - (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum - (start-time (current-seconds)) - (mt-mod-time (file-modification-time mtpath)) - (recently-synced (< (- start-time mt-mod-time) 4)) - (will-sync (and (or need-sync should-sync) - (not sync-in-progress) - (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync) - ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) - ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) - (if will-sync (set! *db-sync-in-progress* #t)) - (mutex-unlock! *db-multi-sync-mutex*) - (if will-sync - (let ((res (common:sync-to-megatest.db dbstruct))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive - (if (> res 0) ;; some records were transferred, keep the db alive - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *db-last-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*) - (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) - (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))) - (if will-sync - (begin - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-sync-in-progress* #f) - (set! *db-last-sync* start-time) - (mutex-unlock! *db-multi-sync-mutex*))) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) - - (if (and (not *time-to-exit*) - (< count 4)) ;; was 11, changing to 4. - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (if (not *time-to-exit*) (loop)))) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) - ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define (common:watchdog) (debug:print-info 13 *default-log-port* "common:watchdog entered.") - (if (common:on-homehost?) - (let ((dbstruct (db:setup))) - (debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct) - (cond - ((dbr:dbstruct-read-only dbstruct) - (debug:print-info 13 *default-log-port* "loading read-only watchdog") - (common:readonly-watchdog dbstruct)) - (else - (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (common:writable-watchdog dbstruct))) - (debug:print-info 13 *default-log-port* "watchdog done.")) - (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))) + (if (launch:setup) + (if (common:on-homehost?) + (let ((dbstruct (db:setup #t))) + (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) + (cond + ((dbr:dbstruct-read-only dbstruct) + (debug:print-info 13 *default-log-port* "loading read-only watchdog") + (common:readonly-watchdog dbstruct)) + (else + (debug:print-info 13 *default-log-port* "loading writable-watchdog.") + (server:writable-watchdog dbstruct))) + (debug:print-info 13 *default-log-port* "watchdog done.")) + (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) (define (std-exit-procedure) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) @@ -776,14 +812,15 @@ (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) - (if (and *runremote* - (remote-conndat *runremote*)) - (begin - (http-client#close-all-connections!))) ;; for http-client + (http-client#close-all-connections!) + ;; (if (and *runremote* + ;; (remote-conndat *runremote*)) + ;; (begin + ;; (http-client#close-all-connections!))) ;; for http-client (if (not (eq? *default-log-port* (current-error-port))) (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") @@ -805,16 +842,27 @@ (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) ;;(debug:print-info 13 *default-log-port* "got signal "signum) - (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") + (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(define (special-signal-handler signum) + ;; (signal-mask! signum) + (set! *time-to-exit* #t) + ;;(debug:print-info 13 *default-log-port* "got signal "signum) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!") + ;;TODO send email to notify admin contact listed in the config that the lisner got killed ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) + (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) + ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== @@ -858,19 +906,19 @@ #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)) + (common: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) + (if (common:file-exists? exe-path) (handle-exceptions exn #f (pathname-directory (pathname-directory @@ -886,12 +934,14 @@ (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions - exn - #f + exn + (begin + (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") + #f) (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) @@ -965,14 +1015,18 @@ (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) (let* (;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) - (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) + (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond + ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig + (if rconf + (runconfigs-get rconf testpatt-key) + #f)) ;; We do NOT fall back to "%" ;; (tags-testpatt ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) ;; tags-testpatt) ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) @@ -986,44 +1040,60 @@ (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) -(define (common:file-exists? path-string) +(define (common:file-exists? path-string #!key (silent #f)) ;; this avoids stack dumps in the case where ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (file-exists? path-string)) - message: (conc "Unable to access path: " path-string) + message: (if (not silent) + (conc "Unable to access path: " path-string) + #f) )) (define (common:directory-exists? path-string) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (directory-exists? path-string)) message: (conc "Unable to access path: " path-string) )) +;; does the directory exist and do we have write access? +;; +;; returns the directory or #f +;; +(define (common:directory-writable? path-string) + (handle-exceptions + exn + #f + (if (and (directory-exists? path-string) + (file-write-access? path-string)) + path-string + #f))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") - (or (and *configdat* - (configf:lookup *configdat* "setup" "linktree")) + (if *configdat* + (configf:lookup *configdat* "setup" "linktree") (if *toppath* (conc *toppath* "/lt") - (if (file-exists? "megatest.config") ;; we are in the toppath (new area, mtutils compatible) - (conc (current-directory) "/lt") - #f))))) + #f)))) (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) + +(define (common:get-fields cfgdat) + (let ((fields (hash-table-ref/default cfgdat "fields" '()))) + (map car fields))) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) - (let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '())) + (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (getenv "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) @@ -1041,10 +1111,20 @@ (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) + +;; looking only (at least for now) at the MT_ variables craft the full testname +;; +(define (common:get-full-test-name) + (if (getenv "MT_TEST_NAME") + (if (and (getenv "MT_ITEMPATH") + (not (equal? (getenv "MT_ITEMPATH") ""))) + (getenv "MT_TEST_NAME") + (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) + #f)) ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; @@ -1079,11 +1159,11 @@ (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) (let ((hhf (conc *toppath* "/.homehost"))) - (if (file-exists? hhf) + (if (common:file-exists? hhf) (with-input-from-file hhf read-line) (if (file-write-access? *toppath*) (begin (with-output-to-file hhf (lambda () @@ -1107,14 +1187,24 @@ #f))) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) - (not (or (args:get-arg "-no-cache") - (and *configdat* - (equal? (configf:lookup *configdat* "setup" "use-cache") "no"))))) - + (let ((res #t)) ;; priority by order of evaluation + (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") + (set! res #f) + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") + (set! res #t)))) + (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" + (if (getenv "MT_USE_CACHE") + (if (equal? (getenv "MT_USE_CACHE") "yes") + (set! res #t) + (if (equal? (getenv "MT_USE_CACHE") "no") + (set! res #f)))) ;; overrides -no-cache switch + res)) + ;; force use of server? ;; (define (common:force-server?) (let* ((force-setting (configf:lookup *configdat* "server" "force")) (force-type (if force-setting (string->symbol force-setting) #f)) @@ -1131,17 +1221,10 @@ (begin (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") #t) #f))) -;; do we honor the caches of the config files? -;; -(define (common:use-cache?) - (not (or (args:get-arg "-no-cache") - (and *configdat* - (equal? (configf:lookup *configdat* "setup" "use-cache") "no"))))) - ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb @@ -1295,10 +1378,33 @@ new-rownames new-colnames (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) + +;; if it looks like a number -> convert it to a number, else return it +;; +(define (common:lazy-convert inval) + (let* ((as-num (if (string? inval)(string->number inval) #f))) + (or as-num inval))) + +;; convert string a=1; b=2; c=a silly thing; d= +;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) +;; +(define (common:val->alist val #!key (convert #f)) + (let ((val-list (string-split-fields ";\\s*" val #:infix))) + (if val-list + (map (lambda (x) + (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) + (case (length f) + ((0) `(,#f)) ;; null string case + ((1) `(,(string->symbol (car f)))) + ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f))) + (if convert (common:lazy-convert inval) inval)))) + (else f)))) + val-list) + '()))) ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== @@ -1358,77 +1464,114 @@ ;; (let ((newval (string->number (cadr match)))) ;; (if (number? newval) ;; (set! cpu-load newval)))))) ;; (car load-res)) ;; cpu-load)) + +;; get values from cached info from dropping file in logs dir +;; e.g. key is host and dtype is normalized-load +;; +(define (common:get-cached-info key dtype #!key (age 5)) + (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log"))) + (if (and (file-exists? fullpath) + (file-read-access? fullpath)) + (handle-exceptions + exn + #f + (debug:print 2 *default-log-port* "reading file " fullpath) + (let ((real-age (- (current-seconds)(file-change-time fullpath)))) + (if (< real-age age) + (with-input-from-file fullpath read) + (begin + (debug:print 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it") + #f)))) + (begin + (debug:print 2 *default-log-port* "not reading file " fullpath) + #f)))) + +(define (common:write-cached-info key dtype dat) + (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log"))) + (handle-exceptions + exn + #f + (with-output-to-file fullpath (lambda ()(pp dat)))))) ;; get cpu load by reading from /proc/loadavg, return all three values ;; (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)))))) + (let* ((actual-hostname (or remote-host (get-host-name)))) + (or (common:get-cached-info actual-hostname "cpu-load") + (let ((result (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))))))) + (common:write-cached-info actual-hostname "cpu-load" result) + result)))) ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads ;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. ;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; (define (common:get-normalized-cpu-load remote-host) - (let ((data (if remote-host - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") - read-lines) - (append - (with-input-from-file "/proc/loadavg" - read-lines) - (with-input-from-file "/proc/cpuinfo" - read-lines) - (list "end")))) - (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) - (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) - (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) - (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) - (max-num (lambda (p n)(max (string->number p) n)))) - ;; (print "data=" data) - (if (null? data) ;; something went wrong - #f - (let loop ((hed (car data)) - (tal (cdr data)) - (loads #f) - (proc-num 0) ;; processor includes threads - (phys-num 0) ;; physical chip on motherboard - (core-num 0)) ;; core - ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) - (if (null? tal) ;; have all our data, calculate normalized load and return result - (let* ((act-proc (+ proc-num 1)) - (act-phys (+ phys-num 1)) - (act-core (+ core-num 1)) - (adj-proc-load (/ (car loads) act-proc)) - (adj-core-load (/ (car loads) act-core))) - (append (list (cons 'adj-proc-load adj-proc-load) - (cons 'adj-core-load adj-core-load)) - (list (cons '1m-load (car loads)) - (cons '5m-load (cadr loads)) - (cons '15m-load (caddr loads))) - (list (cons 'proc act-proc) - (cons 'core act-core) - (cons 'phys act-phys)))) - (regex-case - hed - (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) - (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) - (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) - (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) - (else - (begin - ;; (print "NO MATCH: " hed) - (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))) + (let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost + (or (common:get-cached-info actual-host "normalized-load") + (let ((data (if remote-host + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") + read-lines) + (append + (with-input-from-file "/proc/loadavg" + read-lines) + (with-input-from-file "/proc/cpuinfo" + read-lines) + (list "end")))) + (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) + (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) + (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) + (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) + (max-num (lambda (p n)(max (string->number p) n)))) + ;; (print "data=" data) + (if (null? data) ;; something went wrong + #f + (let loop ((hed (car data)) + (tal (cdr data)) + (loads #f) + (proc-num 0) ;; processor includes threads + (phys-num 0) ;; physical chip on motherboard + (core-num 0)) ;; core + ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) + (if (null? tal) ;; have all our data, calculate normalized load and return result + (let* ((act-proc (+ proc-num 1)) + (act-phys (+ phys-num 1)) + (act-core (+ core-num 1)) + (adj-proc-load (/ (car loads) act-proc)) + (adj-core-load (/ (car loads) act-core)) + (result + (append (list (cons 'adj-proc-load adj-proc-load) + (cons 'adj-core-load adj-core-load)) + (list (cons '1m-load (car loads)) + (cons '5m-load (cadr loads)) + (cons '15m-load (caddr loads))) + (list (cons 'proc act-proc) + (cons 'core act-core) + (cons 'phys act-phys))))) + (common:write-cached-info actual-host "normalized-load" result) + result) + (regex-case + hed + (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) + (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) + (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) + (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) + (else + (begin + ;; (print "NO MATCH: " hed) + (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) @@ -1435,16 +1578,16 @@ ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; ;; return list of ;; ( reachable? cpuload update-time ) (define (common:get-host-info hostname) - (let* ((loadinfo (rmt:get-latest-host-load hostname)) - (load (car loadinfo)) - (load-sample-time (cdr loadinfo)) - (load-sample-age (- (current-seconds) load-sample-time)) - (loadinfo-timeout-seconds 20) - (host-last-update-timeout-seconds 10) + (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data + (load (car loadinfo)) + (load-sample-time (cdr loadinfo)) + (load-sample-age (- (current-seconds) load-sample-time)) + (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds + (host-last-update-timeout-seconds 4) (host-rec (hash-table-ref/default *host-loads* hostname #f)) ) (cond ((< load-sample-age loadinfo-timeout-seconds) (list #t @@ -1456,14 +1599,18 @@ (host-last-update host-rec) (host-last-cpuload host-rec ))) ((common:unix-ping hostname) (list #t (current-seconds) - (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) + (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds (else - (list #f 0 -1))))) - + (list #f 0 -1) ;; bad host, don't use! + )))) + +;; see defstruct host at top of file. +;; host: reachable last-update last-used last-cpuload +;; (define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw))) (for-each @@ -1481,80 +1628,133 @@ (host-reachable-set! rec is-reachable) (host-last-update-set! rec last-reached-time) (host-last-cpuload-set! rec load))) hosts))) -(define (common:get-least-loaded-host hosts-raw) - (let* ((hosts (filter (lambda (x) - (string-match (regexp "^\\S+$") x)) - hosts-raw)) - (best-host #f) +;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the +;; [host-rules] section. +;; +(define (common:get-least-loaded-host hosts-raw host-type configdat) + (let* ((rdat (configf:lookup configdat "host-rules" host-type)) + (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate + (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load + (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs + (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second + (hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw)) + ;; (best-host #f) + (get-rec (lambda (hostname) + ;; (print "get-rec hostname=" hostname) + (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h))))) (best-load 99999) - (curr-time (current-seconds))) - (common:update-host-loads-table hosts) - (for-each - (lambda (hostname) - (let* ((rec - (let ((h (hash-table-ref/default *host-loads* hostname #f))) - (if h - h - (let ((h (make-host))) - (hash-table-set! *host-loads* hostname h) - h)))) - (reachable (host-reachable rec)) - (load (host-last-cpuload rec))) - (cond - ((not reachable) #f) - ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut - (+ best-load (/ (random 250) 1000)) ) - (set! best-load load) - (set! best-host hostname))))) - hosts) - best-host)) - - - - -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) + (curr-time (current-seconds)) + (get-hosts-sorted (lambda (hosts) + (sort hosts (lambda (a b) + (let ((a-rec (get-rec a)) + (b-rec (get-rec b))) + ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec)) + ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec)) + (< (host-last-used a-rec) + (host-last-used b-rec)))))))) + (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts)) + (if (null? hosts) + #f ;; no hosts to select from. All done and giving up now. + (let ((hosts-sorted (get-hosts-sorted hosts))) + (common:update-host-loads-table hosts) + (let loop ((hostname (car hosts-sorted)) + (tal (cdr hosts-sorted)) + (best-host #f)) + (let* ((rec (get-rec hostname)) + (reachable (host-reachable rec)) + (load (host-last-cpuload rec)) + (last-used (host-last-used rec)) + (delta (- curr-time last-used)) + (job-rate (if (> delta 0) + (/ 1 delta) + 999)) ;; jobs per second + (new-best + (cond + ((not reachable) + (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.") + best-host) + ((and (< load maxnload) ;; load is acceptable + (< job-rate maxjobrate)) ;; job rate is acceptable + (set! best-load load) + hostname) + (else best-host)))) + (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." ) + (if new-best + (begin ;; found a host, return it + (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate) + (host-last-used-set! rec curr-time) + new-best) + (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) + +(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) + (numcpus (if (< 1 numcpus-in) ;; not possible + (common:get-num-cpus remote-host) + numcpus-in)) + (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME? (first (car loadavg)) (next (cadr loadavg)) - (adjload (* maxload numcpus)) - (loadjmp (- first next))) + (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 + (loadjmp (- first next)) + (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously (cond ((and (> first adjload) (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg "")) + (thread-sleep! adjwait) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) ((and (> loadjmp numcpus) (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " 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)))))) + (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) + (thread-sleep! adjwait) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))))) + +(define (common:wait-for-homehost-load maxload msg) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (common:get-homehost))) + (hh (if hh-dat (car hh-dat) #f)) + (numcpus (common:get-num-cpus hh))) + (common:wait-for-normalized-load maxload msg hh))) (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)))) + (let* ((actual-host (or remote-host (get-host-name)))) + (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often! + (let* ((proc (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + (begin + (common:write-cached-info remote-host "num-cpus" numcpu) + numcpu) + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line)))))) + (result (if remote-host + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/cpuinfo") + proc) + (with-input-from-file "/proc/cpuinfo" proc)))) + (common:write-cached-info actual-host "num-cpus" result) + result)))) ;; wait for normalized cpu load to drop below maxload ;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) +(define (common:wait-for-normalized-load maxload msg remote-host) (let ((num-cpus (common:get-num-cpus remote-host))) - (common:wait-for-cpuload maxload num-cpus 15 msg: msg))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) @@ -1708,11 +1908,12 @@ (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) - (print (if (member key ignorevars) + (print (if (or (member key ignorevars) + (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) envvars))) (with-output-to-file (conc fname ".sh") @@ -1722,32 +1923,55 @@ (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) (print (if (or (member key ignorevars) + (string-search whitesp key) (string-search ":" key)) ;; internal only values to be skipped. "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) + +(define (common:get-param-mapping #!key (flavor #f)) + "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" + (let ((default '(("tag-expr" . "-tagexpr") + ("mode-patt" . "-modepatt") + ("run-name" . "-runname") + ("contour" . "-contour") + ("target" . "-target") + ("test-patt" . "-testpatt") + ("msg" . "-m") + ("log" . "-log") + ("start-dir" . "-start-dir") + ("new" . "-set-state-status")))) + (if (eq? flavor 'switch-symbol) + (map (lambda (x) + (cons (string->symbol (conc "-" (car x))) (cdr x))) + default) + default))) + ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) +;; a value of #f means "unset this var" +;; (define (alist->env-vars lst) (if (list? lst) (let ((res '())) (for-each (lambda (p) (let* ((var (car p)) (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val - (setenv var (->string val)) + (safe-setenv var (->string val)) (unsetenv var)))) lst) res) '())) + ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; @@ -1770,10 +1994,11 @@ (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) + (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) @@ -1788,27 +2013,30 @@ ;; T I M E A N D D A T E ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) - (let ((parts (string-split tstr)) + (let ((parts (string-split-fields "\\w+" tstr)) (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days - (trx (regexp "(\\d+)([smhd])"))) + ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks + (trx (regexp "(\\d+)([smhdMyw])"))) (for-each (lambda (part) (let ((match (string-match trx part))) (if match (let ((val (string->number (cadr match))) (unt (caddr match))) (if val (set! time-secs (+ time-secs (* val (case (string->symbol unt) ((s) 1) - ((m) 60) - ((h) (* 60 60)) - ((d) (* 24 60 60)) - (else 0)))))))))) + ((m) 60) ;; minutes + ((h) 3600) + ((d) 86400) + ((w) 604800) + ((M) 2628000) ;; aproximately one month + ((y) 31536000) + (else #f)))))))))) parts) time-secs)) (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) @@ -2091,25 +2319,47 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) -(define (common:faux-lock keyname) - (if (rmt:get-var keyname) - #f +;;====================================================================== +;; L O C K I N G M E C H A N I S M S +;;====================================================================== + +;; faux-lock is deprecated. Please use simple-lock below +;; +(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) + (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count + (if (> wait-time 0) + (begin + (thread-sleep! 1) + (if (eq? wait-time 1) ;; only one second left, steal the lock + (begin + (debug:print-info 0 *default-log-port* "stealing lock for " keyname) + (common:faux-unlock keyname force: #t))) + (common:faux-lock keyname wait-time: (- wait-time 1))) + #f) (begin - (rmt:set-var keyname (conc (current-process-id))) - (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) + (rmt:no-sync-set keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))))) (define (common:faux-unlock keyname #!key (force #f)) - (if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) (begin - (if (rmt:get-var keyname) (rmt:del-var keyname)) + (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) - +;; simple lock. improve and converge on this one. +;; +(define (common:simple-lock keyname) + (rmt:no-sync-get-lock keyname)) + +;;====================================================================== +;; +;;====================================================================== + (define (common:in-running-test?) (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) (define (common:get-color-from-status status) (cond @@ -2120,93 +2370,81 @@ ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) -;;====================================================================== -;; N A N O M S G C L I E N T -;;====================================================================== - -(define (server:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - - -(define (common:send-dboard-main-changed) - (let* ((dashboard-ips (mddb:get-dashboards))) - (for-each - (lambda (ipadr) - (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) - (msg (conc "main " *toppath*)) - (res (common:nm-send-receive-timeout soc msg))) - (if (not res) ;; couldn't reach that dashboard - remove it from db - (print "ERROR: couldn't reach dashboard " ipadr)) - res)) - dashboard-ips))) - - -;;====================================================================== -;; D A S H B O A R D D B -;;====================================================================== - -(define (mddb:open-db) - (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) - (set-busy-handler! db (busy-timeout 10000)) - (for-each - (lambda (qry) - (exec (sql db qry))) - (list - "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" - "CREATE TABLE IF NOT EXISTS dashboards ( - id INTEGER PRIMARY KEY, - pid INTEGER, - username TEXT, - hostname TEXT, - ipaddr TEXT, - portnum INTEGER, - start_time TIMESTAMP DEFAULT (strftime('%s','now')), - CONSTRAINT hostport UNIQUE (hostname,portnum) - );" - )) - db)) - -;; register a dashboard -;; -(define (mddb:register-dashboard port) - (let* ((pid (current-process-id)) - (hostname (get-host-name)) - (ipaddr (server:get-best-guess-address hostname)) - (username (current-user-name)) ;; (car userinfo))) - (db (mddb:open-db))) - (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) - (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") - pid username hostname ipaddr port) - (close-database db))) - -;; unregister a monitor -;; -(define (mddb:unregister-dashboard host port) - (let* ((db (mddb:open-db))) - (print "Register unregister monitor, host:port=" host ":" port) - (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) - (close-database db))) - -;; get registered dashboards -;; -(define (mddb:get-dashboards) - (let ((db (mddb:open-db))) - (query fetch-column - (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) +;; ;;====================================================================== +;; ;; N A N O M S G C L I E N T +;; ;;====================================================================== +;; +;; +;; +;; (define (common:send-dboard-main-changed) +;; (let* ((dashboard-ips (mddb:get-dashboards))) +;; (for-each +;; (lambda (ipadr) +;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) +;; (msg (conc "main " *toppath*)) +;; (res (common:nm-send-receive-timeout soc msg))) +;; (if (not res) ;; couldn't reach that dashboard - remove it from db +;; (print "ERROR: couldn't reach dashboard " ipadr)) +;; res)) +;; dashboard-ips))) +;; +;; +;; ;;====================================================================== +;; ;; D A S H B O A R D D B +;; ;;====================================================================== +;; +;; (define (mddb:open-db) +;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) +;; (set-busy-handler! db (busy-timeout 10000)) +;; (for-each +;; (lambda (qry) +;; (exec (sql db qry))) +;; (list +;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" +;; "CREATE TABLE IF NOT EXISTS dashboards ( +;; id INTEGER PRIMARY KEY, +;; pid INTEGER, +;; username TEXT, +;; hostname TEXT, +;; ipaddr TEXT, +;; portnum INTEGER, +;; start_time TIMESTAMP DEFAULT (strftime('%s','now')), +;; CONSTRAINT hostport UNIQUE (hostname,portnum) +;; );" +;; )) +;; db)) +;; +;; ;; register a dashboard +;; ;; +;; (define (mddb:register-dashboard port) +;; (let* ((pid (current-process-id)) +;; (hostname (get-host-name)) +;; (ipaddr (server:get-best-guess-address hostname)) +;; (username (current-user-name)) ;; (car userinfo))) +;; (db (mddb:open-db))) +;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) +;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") +;; pid username hostname ipaddr port) +;; (close-database db))) +;; +;; ;; unregister a monitor +;; ;; +;; (define (mddb:unregister-dashboard host port) +;; (let* ((db (mddb:open-db))) +;; (print "Register unregister monitor, host:port=" host ":" port) +;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) +;; (close-database db))) +;; +;; ;; get registered dashboards +;; ;; +;; (define (mddb:get-dashboards) +;; (let ((db (mddb:open-db))) +;; (query fetch-column +;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) ;;====================================================================== ;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S ;;====================================================================== ;; @@ -2217,10 +2455,16 @@ ;; ;; [host-types] ;; general #MTLOWESTLOAD #{g hosts allhosts} ;; arm #MTLOWESTLOAD #{g hosts arm} ;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo +;; +;; [host-rules] +;; # maxnload => max normalized load +;; # maxnjobs => max jobs per cpu +;; # maxjobrate => max jobs per second +;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 ;; ;; [launchers] ;; envsetup general ;; xor/%/n 4C16G ;; % nbgeneral @@ -2247,12 +2491,23 @@ (let ((launcher (configf:lookup configdat "host-types" host-type))) (if launcher (let* ((launcher-parts (string-split launcher)) (launcher-exe (car launcher-parts))) (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline - (let ((targ-host (common:get-least-loaded-host (cdr launcher-parts)))) - (conc "remrun " targ-host)) + (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)) + (count 100)) + (if targ-host + (conc "remrun " targ-host) + (if (> count 0) + (begin + (debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type) + (thread-sleep! (- 101 count)) + (host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat) + (- count 1))) + (begin + (debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type) + (exit))))) launcher)) (begin (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type) (if (null? tal) fallback-launcher @@ -2260,11 +2515,51 @@ ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) + +;;====================================================================== +;; NMSG AND NEW API +;;====================================================================== + +;; nm based server experiment, keep around for now. +;; +(define (nm:start-server dbconn #!key (given-host-name #f)) + (let* ((srvdat (start-raw-server given-host-name: given-host-name)) + (host-name (srvdat-host srvdat)) + (soc (srvdat-soc srvdat))) + + ;; start the queue processor (save for second round of development) + ;; + (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor"))) + ;; msg is an alist + ;; 'r host:port <== where to return the data + ;; 'p params <== data to apply the command to + ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default + ;; 'c command <== look up the function to call using this key + ;; + (let loop ((msg-in (nn-recv soc))) + (if (not (equal? msg-in "quit")) + (let* ((dat (decode msg-in)) + (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client + (params (alist-ref 'p dat)) + (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) + (all-good (and host-port params command (hash-table-exists? *commands* command)))) + (if all-good + (let ((cmddat (make-qitem + command: command + host-port: host-port + params: params))) + (queue-push cmddat) ;; put request into the queue + (nn-send soc "queued")) ;; reply with "queued" + (print "ERROR: BAD request " dat)) + (loop (nn-recv soc))))) + (nn-close soc))) + + ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists @@ -2271,12 +2566,265 @@ ;; (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) - (if (file-exists? mthome-cfgfile) + (if (common:file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas - (if (file-exists? home-cfgfile) + (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) +;;====================================================================== +;; H I E R A R C H I C A L H A S H T A B L E S +;;====================================================================== + +;; Every element including top element is a vector: +;; + +(define (hh:make-hh #!key (ht #f)(value #f)) + (vector (or ht (make-hash-table)) value)) + +;; used internally +(define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) +(define-inline (hh:get-ht hh) (vector-ref hh 0)) +(define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) +(define-inline (hh:get-value hh value) (vector-ref hh 1)) + +;; given a hierarchial hash and some keys look up the value ... +;; +(define (hh:get hh . keys) + (if (null? keys) + (vector-ref hh 1) ;; we have reached the end of the line, return the value sought + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if sub-hh + (apply hh:get sub-hh (cdr keys)) + #f)) + #f)))) + +;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value +;; +(define (hh:set! hh value . keys) + (if (null? keys) + (hh:set-value! hh value) ;; we have reached the end of the line, store the value + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if (not sub-hh) ;; we'll need to add the next level of hierarchy + (let ((new-sub-hh (hh:make-hh))) + (hash-table-set! sub-ht (car keys) new-sub-hh) + (apply hh:set! new-sub-hh value (cdr keys))) + (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys + (begin + (hh:set-ht! hh (make-hash-table)) + (apply hh:set! hh value keys)))))) + +;; Manage pkts, used in servers, tests and likely other contexts so put +;; in common +;;====================================================================== + +(define common:pkts-spec + '((default . ((parent . P) + (action . a) + (filename . f))) + (configf . ((parent . P) + (action . a) + (filename . f))) + (server . ((action . a) + (pid . d) + (ipaddr . i) + (port . p) + (parent . P))) + + (test . ((cpuuse . c) + (diskuse . d) + (item-path . i) + (runname . r) + (state . s) + (target . t) + (status . u) + (parent . P))))) + +(define (common:get-pkts-dirs mtconf use-lt) + (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") + (and use-lt + (conc (or *toppath* + (current-directory)) + "/lt/.pkts")))) + (pktsdirs (if pktsdirs-str + (string-split pktsdirs-str " ") + #f))) + pktsdirs)) + +;; use-lt is use linktree "lt" link to find pkts dir +(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already + (if (or add-only + (hash-table-exists? *pkts-info* 'last-parent)) + (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f)) + (pktalist (if parent + (cons `(parent . ,parent) + pktalist-in) + pktalist-in))) + (let-values (((uuid pkt) + (alist->pkt pktalist common:pkts-spec))) + (hash-table-set! *pkts-info* 'last-parent uuid) + (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f) + (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) + (pktsdir (car pktsdirs))) ;; assume it is there + (hash-table-set! *pkts-info* 'pkts-dir pktsdir) + pktsdir)))) + (handle-exceptions + exn + (debug:print-info 0 "failed to write out packet to " pktsdir) ;; don't care if this failed for now but MUST FIX - BUG!! + (if (not (file-exists? pktsdir)) + (create-directory pktsdir #t)) + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt))))))))) + +(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f)) + (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) + (pktsdir (if pktsdirs (car pktsdirs) #f)) + (toppath (or (configf:lookup mtconf "scratchdat" "toppath") + toppath-in)) + (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) + (cond + ((not (and pktsdir toppath pdbpath)) + (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.") + (debug:print 0 *default-log-port* " you need to have pktsdir in the [setup] section.")) + ((not (common:file-exists? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir)) + ((not (equal? (file-owner pktsdir)(current-effective-user-id))) + (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name))) + (else + (let* ((pdb (open-queue-db pdbpath "pkts.db" + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) + (proc pktsdirs pktsdir pdb) + (dbi:close pdb)))))) + +(define (common:load-pkts-to-db mtconf #!key (use-lt #f)) + (common:with-queue-db + mtconf + (lambda (pktsdirs pktsdir pdb) + (for-each + (lambda (pktsdir) ;; look at all + (cond + ((not (common:file-exists? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) + ((not (directory? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) + ((not (file-read-access? pktsdir)) + (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) + (else + (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) + (let ((pkts (glob (conc pktsdir "/*.pkt")))) + (for-each + (lambda (pkt) + (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) + (exists (lookup-by-uuid pdb uuid #f))) + (if (not exists) + (let* ((pktdat (string-intersperse + (with-input-from-file pkt read-lines) + "\n")) + (apkt (pkt->alist pktdat)) + (ptype (alist-ref 'T apkt))) + (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) + (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) + (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") + ))) + pkts))))) + pktsdirs)) + use-lt: use-lt)) + +(define (common:get-pkt-alists pkts) + (map (lambda (x) + (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt + pkts)) + +;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending +;; also delete duplicates by target i.e. (car pkt) +;; +(define (common:get-pkt-times pkts) + (delete-duplicates + (sort + (map (lambda (x) + `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) + pkts) + (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending + (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target + + + +;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) +;; execute thunk in context of environment modified as per this list +;; restore env to prior state then return value of eval'd thunk. +;; ** this is not thread safe ** +(define (common:with-env-vars delta-env-alist-or-hash-table thunk) + (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) + (hash-table->alist delta-env-alist-or-hash-table) + delta-env-alist-or-hash-table)) + (restore-thunks + (filter + identity + (map (lambda (env-pair) + (let* ((env-var (car env-pair)) + (new-val (cadr env-pair)) + (current-val (get-environment-variable env-var)) + (restore-thunk + (cond + ((not current-val) (lambda () (unsetenv env-var))) + ((not (string? new-val)) #f) + ((eq? current-val new-val) #f) + (else + (lambda () (setenv env-var current-val)))))) + ;;(when (not (string? new-val)) + ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) + ;; (pp delta-env-alist) + ;; (exit 1)) + + + (cond + ((not new-val) ;; modify env here + (unsetenv env-var)) + ((string? new-val) + (setenv env-var new-val))) + restore-thunk)) + delta-env-alist)))) + (let ((rv (thunk))) + (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state + rv))) + +(define *common:thread-punchlist* (make-hash-table)) +(define (common:send-thunk-to-background-thread thunk #!key (name #f)) + ;;(BB> "launched thread " name) + + ;; we need a unique name for the thread. + (let* ((realname (if name + (if (not (hash-table-ref/default *common:thread-punchlist* name #f)) + name + (conc name"-" (symbol->string (gensym)))) + (conc "anonymous-"(symbol->string (gensym))))) + (realthunk (lambda () + (let ((res (thunk))) + (hash-table-delete! *common:thread-punchlist* realname) + res))) + (thread (make-thread realthunk realname))) + (hash-table-set! *common:thread-punchlist* realname thread) + (thread-start! thread) + )) + +(define (common:join-backgrounded-threads) + ;; may need to trap and ignore exceptions -- dunno how atomic threads are... + (for-each + (lambda (thread-name) + (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f))) + (if thread + (handle-exceptions + exn + #t ;; just ignore it, it might have died in the meantime so joining it will throw an exception + (thread-join! thread)) + ))) + (hash-table-keys *common:thread-punchlist*))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -147,15 +147,17 @@ (temp (string-split (->string this-loc) " ")) (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) - (let ((dp-args - (append - (list 0 *default-log-port* - (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) - in-args))) + (let* ((color-on "\x1b[1m") + (color-off "\x1b[0m") + (dp-args + (append + (list 0 *default-log-port* + (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) + in-args))) (apply debug:print dp-args)))) (define *BBpp_custom_expanders_list* (make-hash-table)) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -23,18 +23,18 @@ ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) - (if (file-exists? cfname) + (if (common:file-exists? cfname) (list toppath cfname configname) (list #f #f #f))) (let* ((cwd (string-split (current-directory) "/"))) (let loop ((dir cwd)) (let* ((path (conc "/" (string-intersperse dir "/"))) (fullpath (conc path "/" configname))) - (if (file-exists? fullpath) + (if (common:file-exists? fullpath) (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) @@ -77,10 +77,14 @@ (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) + +(define (configf:system ht cmd) + (system cmd) + ) (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) @@ -92,11 +96,11 @@ (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym ((scheme scm) (conc "(lambda (ht)" cmd ")")) - ((system) (conc "(lambda (ht)(system \"" cmd "\"))")) + ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) ((mtrah) (conc "(lambda (ht)" " (let ((extra \"" cmd "\"))" @@ -176,11 +180,27 @@ (configf:process-line inl ht allow-processing))))) (if (and (string? res) (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) (string-substitute "\\s+$" "" res) res)))))) - + +(define (configf:cfgdat->env-alist section cfgdat-ht allow-system) + (filter + (lambda (pair) + (let* ((var (car pair)) + (val (cdr pair))) + (cons var + (cond + ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic + (val)) + ((procedure? val) #f) + ((string? val) val) + (else "#f"))))) + (append + (hash-table-ref/default cfgdat-ht "default" '()) + (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) + (define (calc-allow-system allow-system section sections) (if sections (and (or (equal? "default" section) (member section sections)) allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings @@ -217,22 +237,34 @@ ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) +;; allow-system: +;; #f - do not evaluate [system +;; #t - immediately evaluate [system and store result as string +;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time +;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; -(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) +(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) (sections #f) (settings (make-hash-table)) (keep-filenames #f) - (post-section-procs '()) (apply-wildcards #t)) + (post-section-procs '()) (apply-wildcards #t) ) (debug:print 9 *default-log-port* "START: " path) +;; (if *configdat* +;; (common:save-pkt `((action . read-config) +;; (f . ,(cond ((string? path) path) +;; ((port? path) "port") +;; (else (conc path)))) +;; (T . configf)) +;; *configdat* #t add-only: #t)) (if (and (not (port? path)) - (not (file-exists? path))) ;; for case where we are handed a port + (not (common:file-exists? path))) ;; for case where we are handed a port (begin (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (if (string? path) @@ -265,146 +297,183 @@ (lambda (section) (if (not (member section sections)) (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht (hash-table-keys res))) (debug:print 9 *default-log-port* "END: " path) - res) + res + ) ;; retval (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (configf:settings ( x setting val ) (begin - (hash-table-set! settings setting val) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) - (full-conf (if (absolute-pathname? include-file) - include-file - (common:nice-path - (conc (if curr-conf-dir - curr-conf-dir - ".") - "/" include-file))))) - (if (file-exists? full-conf) - (begin - ;; (push-directory conf-dir) - (debug:print 9 *default-log-port* "Including: " full-conf) - (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - ;; (pop-directory) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 *default-log-port* " " full-conf) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + (configf:settings ( x setting val ) + (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))) + + (configf:include-rx ( x include-file ) + (let* ((curr-conf-dir (pathname-directory path)) + (full-conf (if (absolute-pathname? include-file) + include-file + (common:nice-path + (conc (if curr-conf-dir + curr-conf-dir + ".") + "/" include-file))))) + (if (common:file-exists? full-conf) + (begin + ;; (push-directory conf-dir) + (debug:print 9 *default-log-port* "Including: " full-conf) + (read-config full-conf res allow-system environ-patt: environ-patt + curr-section: curr-section-name sections: sections settings: settings + keep-filenames: keep-filenames) + ;; (pop-directory) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " full-conf) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))))) (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (file-exists? include-script)(file-execute-access? include-script)) - (let* ((new-inp-port (open-input-pipe (conc include-script " " params)))) - (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) - ;; (print "We got here, calling read-config next. Port is: " new-inp-port) - (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - (close-input-port new-inp-port) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - ) ;; ) - (configf:section-rx ( x section-name ) (begin - ;; call post-section-procs - (for-each - (lambda (dat) - (let ((patt (car dat)) - (proc (cdr dat))) - (if (string-match patt curr-section-name) - (proc curr-section-name section-name res path)))) - post-section-procs) - ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards - ;; NOTE: we are processing the curr-section-name, NOT section-name. - (process-wildcards res curr-section-name) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - ;; if we have the sections list then force all settings into "" and delete it later? - ;; (if (or (not sections) - ;; (member section-name sections)) - ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. - section-name - #f #f))) - (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections) - (let ((alist (hash-table-ref/default res curr-section-name '())) - (val-proc (lambda () - (let* ((start-time (current-seconds)) - (cmdres (process:cmd-run->list cmd)) - (delta (- (current-seconds) start-time)) - (status (cadr cmdres)) - (res (car cmdres))) - (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) - (if (not (eq? status 0)) - (begin - (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status - " output: " cmdres))) - (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) - (if (null? res) - "" - (string-intersperse res " ")))))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist - key - (case (calc-allow-system allow-system curr-section-name sections) - ((return-procs) val-proc) - ((return-string) cmd) - (else (val-proc))) - metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") - (safe-setenv key fval) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key fval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) - (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (config:eval-string-in-environment val) - val))) - (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar (safe-setenv key realval)) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) + (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (new-inp-port + (common:with-env-vars + env-delta + (lambda () + (open-input-pipe (conc include-script " " params)))))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) + (configf:section-rx ( x section-name ) + (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + ;; if we have the sections list then force all settings into "" and delete it later? + ;; (if (or (not sections) + ;; (member section-name sections)) + ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. + section-name + #f #f))) + (configf:key-sys-pr ( x key cmd ) + (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((start-time (current-seconds)) + (local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist + key + (case (calc-allow-system allow-system curr-section-name sections) + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name #f #f))) + + (configf:key-no-val ( x key val) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name key #f))) + + (configf:key-val-pr ( x key unk1 val unk2 ) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name key #f))) ;; if a continued line - (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) - (if var-flag ;; if set to a string then we have a continued var - (let ((newval (conc - (config-lookup res curr-section-name var-flag) "\n" - ;; trim lead from the incoming whsp to support some indenting. - (if lead - (string-substitute (regexp lead) "" whsp) - "") - val))) - ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist var-flag newval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (configf:cont-ln-rx ( x whsp val ) + (let ((alist (hash-table-ref/default res curr-section-name '()))) + (if var-flag ;; if set to a string then we have a continued var + (let ((newval (conc + (config-lookup res curr-section-name var-flag) "\n" + ;; trim lead from the incoming whsp to support some indenting. + (if lead + (string-substitute (regexp lead) "" whsp) + "") + val))) + ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + ) ;; end loop + ))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo)) (set-fields (lambda (curr-section next-section ht path) - (let ((field-names (if ht (keys:config-get-fields ht) '())) + (let ((field-names (if ht (common:get-fields ht) '())) (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (if toppath (change-directory toppath)) (if (and toppath pathenvvar)(setenv pathenvvar toppath)) @@ -423,21 +492,51 @@ (cadr match) #f)) )) #f)) +;; use to have definitive setting: +;; [foo] +;; var yes +;; +;; (configf:var-is? cfgdat "foo" "var" "yes") => #t +;; +(define (configf:var-is? cfgdat section var expected-val) + (equal? (configf:lookup cfgdat section var) expected-val)) + (define configf:lookup config-lookup) (define configf:read-file read-config) + +;; safely look up a value that is expected to be a number, return +;; a default (#f unless provided) +;; +(define (configf:lookup-number cfdat section varname #!key (default #f)) + (let* ((val (configf:lookup *configdat* section varname)) + (res (if val + (string->number (string-substitute "\\s+" "" val #t)) + #f))) + (cond + (res res) + (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) + (else default)))) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat)))) (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) + +(define (configf:set-section-var cfgdat section var val) + (let ((sectdat (configf:get-section cfgdat section))) + (hash-table-set! cfgdat section + (config:assoc-safe-add sectdat var val)))) + + ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) + ;; (list var val)))) (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config @@ -487,11 +586,11 @@ (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))) (define (configf:file->list fname) - (if (file-exists? fname) + (if (common:file-exists? fname) (let ((inp (open-input-file fname))) (let loop ((inl (read-line inp)) (res '())) (if (eof-object? inl) (begin @@ -591,11 +690,11 @@ ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) - (if (not (file-exists? sheets-file)) + (if (not (common:file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) (if (not (file-read-access? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () @@ -663,36 +762,33 @@ #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (if (common:faux-lock fname) - (let* ((dat (configf:config->alist cdat)) - (res - (begin - (with-output-to-file fname ;; first write out the file - (lambda () - (pp dat))) - - (if (common:file-exists? fname) ;; now verify it is readable - (if (configf:read-alist fname) - #t ;; data is good. - (begin - (handle-exceptions - exn - #f - (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") - (delete-file fname)) - #f)) - #f)))) - - (common:faux-unlock fname) - res) - (begin - (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) - #f))) - + (if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + #f + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + (common:faux-unlock fname) + res)) + ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map (lambda (section) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -28,10 +28,11 @@ (declare (uses gutils)) (declare (uses rmt)) (declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) +(declare (uses subrun)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -40,16 +41,26 @@ ;;====================================================================== (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 "viewscreen "))) ;; "xterm -geometry 180x20 -e \""))) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "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'\" &"))) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";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" @@ -233,20 +244,20 @@ ))))) ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) - (let* ((subarea (configf:lookup testconfig "setup" "submegatest")) - (area-exists (and subarea (file-exists? subarea)))) - ;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (subarea (subrun:get-runarea test-run-dir)) + (area-exists (and subarea (common:file-exists? subarea silent: #t)))) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" #:action (lambda (obj) - (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))) + (subrun:launch-dashboard test-run-dir)))) (iup:vbox)))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) @@ -458,11 +469,11 @@ "/")) (item-path (db:test-get-item-path testdat)) ;; this next block was added to fix a bug where variables were ;; needed. Revisit this. (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read - (if (file-exists? runconfigf) + (if (common:file-exists? runconfigf) (handle-exceptions exn #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) @@ -469,21 +480,21 @@ (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) - (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t)))) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) (viewlog (lambda (x) - (if (file-exists? logfile) + (if (common:file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dcommon:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) - (if (file-exists? lfilename) + (if (common:file-exists? lfilename) ;(system (conc "firefox " logfile "&")) (dcommon:run-html-viewer lfilename) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) @@ -496,11 +507,11 @@ "MT_.*")) (message-window (conc "Directory " rundir " not found"))))) (widgets (make-hash-table)) (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) - ;; (max ..... (if (file-exists? testdat-path) + ;; (max ..... (if (common:file-exists? testdat-path) ;; (file-modification-time testdat-path) ;; (begin ;; (set! testdat-path (conc rundir "/testdat.db")) ;; 0)))) (need-update (or (and (>= curr-mod-time db-mod-time) @@ -616,15 +627,16 @@ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) - (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) - ";megatest -target " keystring " -runname " runname + ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -14,11 +14,11 @@ (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) - +(use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) @@ -32,11 +32,11 @@ (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses vg)) - +(declare (uses subrun)) ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (declare (uses mt)) (include "common_records.scm") @@ -47,11 +47,11 @@ (include "vg_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2016 + license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check @@ -85,10 +85,11 @@ "-v" "-q" "-use-db-cache" "-skip-version-check" "-repl" + "-rh5.11" ;; fix to allow running on rh5.11 ) args:arg-hash 0)) (if (not (null? remargs)) @@ -105,10 +106,18 @@ ;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or (args:get-arg "-rh5.11") + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) (if (not (common:on-homehost?)) (begin (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) @@ -204,11 +213,13 @@ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) - ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; + ((numruns (string->number (or (args:get-arg "-cols") + (configf:lookup *configdat* "dashboard" "cols") + "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id @@ -222,11 +233,11 @@ (runs-matrix #f) ;; used in newdashboard ((start-run-offset 0) : number) ;; left-right slider value ((start-test-offset 0) : number) ;; up-down slider value ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 - ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 ((all-test-names '()) : list) ;; Canvas and drawing data (cnv #f) (cnv-obj #f) @@ -314,10 +325,25 @@ (lambda (alist-entry) (member (car alist-entry) '(allruns-by-id allruns))) ;; FIELDS OF INTEREST (dboard:tabdat->alist tabdat-item))))) + +(define (dboard:launch-testpanel run-id test-id) + (let* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh")) + ;; (cmd (conc + ;; (if (common:file-exists? cfg-sh) + ;; (conc "source "cfg-sh" && ") + ;; "") + ;; *common:this-exe-fullpath* + ;; " -test " run-id "," test-id + ;; " &")) + (cmd (conc *common:this-exe-dir*"/../dashboard " + "-test " run-id "," test-id + " &"))) + (system cmd))) + (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) @@ -339,11 +365,11 @@ (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) + (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 @@ -567,12 +593,11 @@ (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) - (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run - run-id testnamepatt states statuses ;; run-id testpatt states statuses + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order @@ -642,17 +667,15 @@ ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys)) + (keys (rmt:get-keys)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f last-runs-update));;'("id" "runname") + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -725,15 +748,13 @@ ;; (define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -792,11 +813,19 @@ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin - (if (> elapsed-time 2)(print "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")) + (when (> elapsed-time 2) + (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val)) + + + ) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (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))))))) @@ -1001,11 +1030,11 @@ (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) - (if x x ""))))) + (if (string? x) x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values ;; (let ((rown 0) @@ -1085,10 +1114,11 @@ (dboard:tabdat-filters-changed-set! tabdat #t))) (define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) + (mark-for-update tabdat) (set-bg-on-filter commondat tabdat)) ;; force ALL updates to zero (effectively) ;; (define (mark-for-update tabdat) @@ -1376,11 +1406,11 @@ ;; Target, testpatt, state and status input boxes ;; (iup:vbox ;; Command to run, placed over the top of the canvas (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dboard:runs-tree-browser commondat tabdat) + (dboard:runs-tree-browser commondat tabdat) (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) (dcommon:command-testname-selector commondat tabdat update-keyvals)) ;; key-listboxes)) (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) (tb (dboard:tabdat-runs-tree tabdat))) @@ -1397,14 +1427,20 @@ ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; (define (dboard:runs-tree-browser commondat tabdat) - (let* ((txtbox (iup:textbox #:action (lambda (val a b) + (let* ( + (txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () + ;; for the Runs view we put the list of keyvals into tabdat target + ;; for the Run Controls we put then update the run-command (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) @@ -1412,13 +1448,13 @@ ;; #:size "10x30" )) (tb (iup:treebox #:value 0 - #:name "Runs" + #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute." #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () @@ -1440,11 +1476,14 @@ (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) - (iup:vbox tb txtbox))) + (iup:detachbox + (iup:vbox + tb + txtbox)))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -1509,11 +1548,11 @@ (iup:vbox (iup:split #:orientation "HORIZONTAL" #:value 800 (let* ((cnv-obj (iup:canvas - ;; #:size "500x400" + ;; #:size "250x250" ;; "500x400" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:action (make-canvas-action @@ -1554,15 +1593,15 @@ (let* ((hb1 (iup:hbox)) (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) (changed #f) (graph-matrix (iup:matrix #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" + ;; #:expand "YES" ;; "HORIZONTAL" #:scrollbar "YES" #:numcol 10 #:numlin 20 - #:numcol-visible (min 8) + #:numcol-visible 5 ;; (min 8) #:numlin-visible 1 #:click-cb (lambda (obj row col status) (let* ((graph-cell (conc row ":" col)) @@ -1611,35 +1650,35 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) -(define (dboard:get-tests-dat tabdat run-id last-update) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run - run-id - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() - (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() - #f #f ;; offset limit - (dboard:tabdat-hide-not-hide tabdat) ;; not-in - #f #f ;; sort-by sort-order - #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) - *dashboard-mode*) - '()))) ;; get 'em all - ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) +;; (define (dboard:get-tests-dat tabdat run-id last-update) +;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) +;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run +;; run-id +;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") +;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() +;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() +;; #f #f ;; offset limit +;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in +;; #f #f ;; sort-by sort-order +;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval +;; (if (dboard:tabdat-filters-changed tabdat) +;; 0 +;; last-update) +;; *dashboard-mode*) +;; '()))) ;; get 'em all +;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) +;; (sort tdat (lambda (a b) +;; (let* ((aval (vector-ref a 2)) +;; (bval (vector-ref b 2)) +;; (anum (string->number aval)) +;; (bnum (string->number bval))) +;; (if (and anum bnum) +;; (< anum bnum) +;; (string<= aval bval))))))) (define (dashboard:safe-cadr-assoc name lst) (let ((res (assoc name lst))) (if (and res (> (length res) 1)) @@ -1655,16 +1694,17 @@ (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (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)) + (key-vals (map (lambda (key) + (let ((val (db:get-value-by-header run-record runs-header key))) + (if (string? val) val ""))) (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)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) @@ -1689,16 +1729,20 @@ (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))))))) + (b-item-path (db:test-get-item-path b)) + (a-event-time (db:test-get-event_time a)) + (b-event-time (db:test-get-event_time b))) + (if (not (equal? a-test-name b-test-name)) + (> a-event-time b-event-time) + (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)) @@ -1727,12 +1771,11 @@ (define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (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) @@ -1744,13 +1787,11 @@ (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 (db:dispatch-query (dboard:tabdat-access-mode tabdat) - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (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))) @@ -1865,11 +1906,11 @@ (define (dashboard:summary commondat tabdat #!key (tab-num #f)) (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (changed #f)) (iup:vbox (iup:split - #:value 500 + #:value 300 (iup:frame #:title "General Info" (iup:vbox (iup:hbox (iup:label "Area Path") @@ -1902,11 +1943,11 @@ (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. (source (configf:lookup views-cfgdat view-name "source")) (viewgen (configf:lookup views-cfgdat view-name "viewgen")) (updater (configf:lookup views-cfgdat view-name "updater")) (result-child #f)) - (if (and (file-exists? source) + (if (and (common:file-exists? source) (file-read-access? source)) (handle-exceptions exn (begin (print-call-chain) @@ -2046,13 +2087,14 @@ ;; (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" + ;;#:name "Runs" + #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute." #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) @@ -2108,15 +2150,15 @@ (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 " &"))) + (run-id (dboard:tabdat-curr-run-id tabdat))) (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") (cond ((member #\1 status-chars) ;; 1 is left mouse button - (system testpanel-cmd)) + (dboard:launch-testpanel run-id test-id)) ((member #\2 status-chars) ;; 2 is middle mouse button (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu @@ -2159,10 +2201,28 @@ ;;====================================================================== ;; R U N S ;;====================================================================== +(define (dboard:squarify toggles size) + (let loop ((hed (car toggles)) + (tal (cdr toggles)) + (cur '()) + (res '())) + (let* ((ovrflo (>= (length cur) size)) + (newcur (if ovrflo + (list hed) + (cons hed cur))) + (newres (if ovrflo + (cons cur res) + res))) + (if (null? tal) + (if ovrflo + newres + (cons newcur res)) + (loop (car tal)(cdr tal) newcur newres))))) + (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 @@ -2181,10 +2241,20 @@ (iup:hbox (iup:button "Quit" #:action (lambda (obj) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) + (dboard:tabdat-last-data-update-set! tabdat 0) + (dboard:tabdat-last-runs-update-set! tabdat 0) + (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) + (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) + (dboard:tabdat-done-runs-set! tabdat '()) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:commondat-please-update-set! commondat #t) (mark-for-update tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () @@ -2223,17 +2293,17 @@ (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" - #:action (lambda (obj) - (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) - (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - (mark-for-update tabdat)))) + ;; (set! hide-empty (iup:button "HideEmpty" + ;; ;; #:expand HORIZONTAL" + ;; #:expand "NO" #:size "80x15" + ;; #:action (lambda (obj) + ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) + ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) + ;; (mark-for-update tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) @@ -2263,66 +2333,88 @@ ))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle (conc status " ") - #:fontsize btn-fontsz ;; "10" - #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) - (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle (conc state " ") - #:fontsize btn-fontsz - #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) - (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns (dboard:tabdat-tot-runs tabdat))) - (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update tabdat) - (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (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 "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)))) - ))) + (let* ((status-toggles (map (lambda (status) + (iup:toggle (conc status) + #:fontsize 8 ;; btn-fontsz ;; "10" + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) + (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (state-toggles (map (lambda (state) + (iup:toggle (conc state) + #:fontsize 8 ;; btn-fontsz + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) + (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) + (iup:vbox + (iup:hbox + (iup:frame + #:title "states" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify state-toggles 3)))) + (iup:frame + #:title "statuses" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify status-toggles 3))))) + ;; + ;; (iup:frame + ;; #:title "state/status filter" + ;; (iup:vbox + ;; (apply + ;; iup:hbox + ;; (map + ;; (lambda (status-toggle state-toggle) + ;; (iup:vbox + ;; status-toggle + ;; state-toggle)) + ;; status-toggles state-toggles)) + + ;; horizontal slider was here + + ))))) + +(define (dashboard:runs-horizontal-slider tabdat ) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (maxruns (dboard:tabdat-tot-runs tabdat))) + (dboard:tabdat-start-run-offset-set! tabdat val) + (mark-for-update tabdat) + (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (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)) + (define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) (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) - ))) + (launch-testpanel run-id test-id))) (iup:menu-item (conc "View Log " item-test-path) #:action (lambda (obj) @@ -2373,12 +2465,21 @@ ;; (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")))) + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (let* ((rundir (db:test-get-rundir test-info)) + (has-subrun (subrun:subrun-test-initialized? rundir))) + (if has-subrun + (iup:menu-item + "Launch subrun dashboard" + #:action + (lambda (obj) + (subrun:launch-dashboard rundir))) + (iup:vbox))) (iup:menu-item "Run" (iup:menu (iup:menu-item @@ -2415,11 +2516,20 @@ (lambda (obj) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt % " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))))) + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) (iup:menu-item "Test" (iup:menu (iup:menu-item (conc "Rerun " item-test-path) @@ -2438,10 +2548,19 @@ (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 + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) (iup:menu-item (conc "Clean "item-test-path) #:action (lambda (obj) (common:run-a-command @@ -2469,10 +2588,13 @@ (cmd (conc (if (string-search editor-rx editor) (conc "xterm -e " editor) editor) " " tconfig " &"))) (system cmd)))) + + + )))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) @@ -2506,10 +2628,13 @@ (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) + ;; each field (field name is "x" var) live updates + ;; the search filter as it is typed + (dboard:tabdat-target-set! runs-dat #f) ;; ensure the fields text boxes are used and not the info from the tree (mark-for-update runs-dat) (update-search commondat runs-dat x val)))))) (set! i (+ i 1)) res)) keynames))))) @@ -2615,14 +2740,12 @@ )) (if (eq? pressed 0) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " run-id "," test-id "&"))) - (system cmd))) - ))))) + (run-id (db:test-get-run_id (vector-ref buttndat 3)))) + (dboard:launch-testpanel run-id test-id)))))))) (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show @@ -2630,20 +2753,23 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 150 + #:value 100 (dboard:runs-tree-browser commondat runs-dat) (iup:split + #:value 100 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox + #:expand "YES" ;; the header (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst))))) + (apply iup:hbox (reverse bdylst)) + (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW @@ -2688,10 +2814,11 @@ runs-view (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) + ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") @@ -2758,11 +2885,11 @@ (glob (conc dbdir "/*.db*")))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) - (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path)) + (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) (file-modification-time monitor-db-path) -1))) (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case @@ -2887,13 +3014,11 @@ ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (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-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)) @@ -3475,11 +3600,11 @@ ;; The heavy lifting starts here ;;====================================================================== (define (main) (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; - (if (and (file-exists? mtdb-path) + (if (and (common: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... @@ -3534,12 +3659,12 @@ (thread-start! th2) (thread-join! th2))))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (file-exists? debugcontrolf) + (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (if (args:get-arg "-repl") (repl) (main)) Index: datashare-testing/.sretrieve.config ================================================================== --- datashare-testing/.sretrieve.config +++ datashare-testing/.sretrieve.config @@ -1,8 +1,8 @@ [settings] base-dir /tmp/delme_data -allowed-users matt +allowed-users matt allowed-chars [0-9a-zA-Z\-\.]+ allowed-sub-paths [0-9a-zA-Z\-\.]+ [database] location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -226,11 +226,11 @@ (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/datashare.db")) (writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath @@ -413,11 +413,11 @@ paths)) ;; remove existing link and if possible ... ;; create path to next of tip of target, create link back to source (define (datashare:build-dir-make-link source target) - (if (file-exists? target)(datashare:backup-move target)) + (if (common:file-exists? target)(datashare:backup-move target)) (create-directory (pathname-directory target) #t) (create-symbolic-link source target)) (define (datashare:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) @@ -518,11 +518,11 @@ (define (datashare:path->lst path) (string-split path "/")) (define (datashare:pathdat-apply-heuristics configdat path) (cond - ((file-exists? path) "found") + ((common:file-exists? path) "found") (else (conc path " not installed")))) (define (datashare:get-view configdat) (iup:vbox (iup:hbox @@ -692,11 +692,11 @@ (define (datashare:find name paths) (if (null? paths) #f (let loop ((hed (car paths)) (tal (cdr paths))) - (if (file-exists? (conc hed "/" name)) + (if (common:file-exists? (conc hed "/" name)) hed (if (null? tal) #f (loop (car tal)(cdr tal))))))) @@ -706,11 +706,11 @@ (define (datashare:load-config exe-dir exe-name) (let* ((fname (conc exe-dir "/." exe-name ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) - (if (file-exists? fname) + (if (common:file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) (define (datashare:process-action configdat action . args) @@ -785,11 +785,11 @@ versions) (sqlite3:finalize! db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) - (if (file-exists? debugcontrolf) + (if (common:file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (let* ((args (argv)) (prog (car args)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,6 +1,6 @@ -;;====================================================================== +;====================================================================== ;; 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. ;; @@ -188,55 +188,48 @@ ;; 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 . junk) ;; run-id) - (let* ((dbdir (common:get-db-tmp-area))) - (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))) - dbdir)) +(define db:dbfile-path common:get-db-tmp-area) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) ;; 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-open-mutex* (make-mutex)) +;; (define *db-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) - (file-exists (file-exists? fname)) + (file-exists (common:file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) - ;;(mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) (readyfname (conc parent-dir "/.ready-" raw-fname)) - (readyexists (file-exists? readyfname))) + (readyexists (common:file-exists? readyfname))) (if (not readyexists) (common:simple-file-lock-and-wait lockfname)) (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists) (begin + (if (and (configf:lookup *configdat* "setup" "use-wal") (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (print "Creating " fname " in NON-WAL mode.")) + (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) (initproc db))) (if (not readyexists) (begin (common:simple-file-release-lock lockfname) (with-output-to-file @@ -254,11 +247,11 @@ (condition-case (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (let ((db (sqlite3:open-database fname))) - ;;(mutex-unlock! *db-open-mutex*) + ;; (mutex-unlock! *db-open-mutex*) db)) (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) @@ -272,11 +265,11 @@ ;; ;; 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* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) -;; (dbexists (file-exists? dbfile)) +;; (dbexists (common:file-exists? dbfile)) ;; (db (db:lock-create-open dbfile (lambda (db) ;; (handle-exceptions ;; exn ;; (begin ;; ;; (release-dot-lock dbpath) @@ -307,19 +300,19 @@ ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; -(define (db:open-db dbstruct #!key (areapath #f)) ;; TODO: actually use areapath +(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (file-exists? (conc *toppath* "/megatest.db"))) + (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) @@ -337,15 +330,16 @@ (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) (dbr:dbstruct-refndb-set! dbstruct refndb) ;; (mutex-unlock! *rundb-mutex*) - (if (or (not dbfexists) - (and modtimedelta - (> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + (if (and (or (not dbfexists) + (and modtimedelta + (> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + do-sync) (begin - (debug:print 4 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) + (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") ) (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically @@ -353,23 +347,22 @@ ;; 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 #!key (areapath #f)) +(define (db:setup do-sync #!key (areapath #f)) ;; - (cond (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard (else ;;(common:on-homehost?) (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") (let* ((dbstruct (make-dbr:dbstruct))) (when (not *toppath*) (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") (launch:setup areapath: areapath)) (debug:print-info 13 *default-log-port* "Begin db:open-db") - (db:open-db dbstruct areapath: areapath) + (db:open-db dbstruct areapath: areapath do-sync: do-sync) (debug:print-info 13 *default-log-port* "Done db:open-db") (set! *dbstruct-db* dbstruct) ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) dbstruct)))) ;; (else @@ -381,11 +374,11 @@ ;; NOTE: returns a dbdat not a dbstruct! ;; (define (db:open-megatest-db #!key (path #f)(name #f)) (let* ((dbdir (or path *toppath*)) (dbpath (conc dbdir "/" (or name "megatest.db"))) - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) @@ -410,10 +403,25 @@ (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-sync* start-t) (set! *db-last-access* start-t) (mutex-unlock! *db-multi-sync-mutex*) (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) + +(define (db:safely-close-sqlite3-db db #!key (try-num 3)) + (if (<= try-num 0) + #f + (handle-exceptions + exn + (begin + (thread-sleep! 3) + (sqlite3:interrupt! db) + (db:safely-close-sqlite3-db db try-num: (- try-num 1))) + (if (sqlite3:database? db) + (begin + (sqlite3:finalize! db) + #t) + #f)))) ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) (handle-exceptions @@ -425,15 +433,16 @@ (let ((tdbs (map db:dbdat-get-db (stack->list (dbr:dbstruct-dbstack dbstruct)))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) (map (lambda (db) - (if (sqlite3:database? db) - (sqlite3:finalize! db))) + (db:safely-close-sqlite3-db db)) +;; (if (sqlite3:database? db) +;; (sqlite3:finalize! db))) tdbs) - (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) - (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) + (db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) + (db:safely-close-sqlite3-db rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -471,20 +480,22 @@ '("run_duration" #f) '("comment" #f) '("event_time" #f) '("fail_count" #f) '("pass_count" #f) - '("archived" #f)) + '("archived" #f) + '("last_update" #f)) (list "test_steps" '("id" #f) '("test_id" #f) '("stepname" #f) '("state" #f) '("status" #f) '("event_time" #f) '("comment" #f) - '("logfile" #f)) + '("logfile" #f) + '("last_update" #f)) (list "test_data" '("id" #f) '("test_id" #f) '("category" #f) '("variable" #f) @@ -492,11 +503,12 @@ '("expected" #f) '("tol" #f) '("units" #f) '("comment" #f) '("status" #f) - '("type" #f)))) + '("type" #f) + '("last_update" #f)))) ;; needs db to get keys, this is for syncing all tables ;; (define (db:sync-main-list dbstruct) (let ((keys (db:get-keys dbstruct))) @@ -508,11 +520,11 @@ (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")))) + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -537,11 +549,11 @@ (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"") (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) (system (conc "rm -f " dbpath)) - (if (file-exists? fnamejnl) + (if (common:file-exists? fnamejnl) (begin (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl) (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) (system (conc "rm -f " dbdir "/" fnamejnl)))) ;; attempt to recreate database @@ -613,11 +625,11 @@ exn (begin (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) (debug:print 0 *default-log-port* " dbpath: " dbpath) @@ -661,26 +673,42 @@ (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (use-last-update (if last-update - (if (pair? last-update) - (member (car last-update) ;; last-update field name - (map car fields)) - (begin - (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields - #f)) - #f)) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (has-last-update (member "last_update" fields)) + (use-last-update (cond + ((and has-last-update + (member "last_update" fields)) + #t) ;; if given a number, just use it for all fields + ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table + ((and (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields))) #t) + (last-update + (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields + #f) + (else + #f))) + (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for + (if (number? last-update) + last-update + (cdr last-update)) + #f)) + (last-update-field (if use-last-update + (if (number? last-update) + "last_update" + (car last-update)) + #f)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria - (conc " " (car last-update) ">=" (cdr last-update)) + (conc " WHERE " last-update-field " >= " last-update-value) "") ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) @@ -834,12 +862,50 @@ (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;")) + END;") + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);")) +(define (db:adj-target db) + (let ((fields (configf:get-section *configdat* "fields")) + (field-num 0)) + ;; because we will be refreshing the keys table it is best to clear it here + (sqlite3:execute db "DELETE FROM keys;") + (for-each + (lambda (field) + (let ((column (car field)) + (spec (cadr field))) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table") + (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) + ;; Add the column if needed + (sqlite3:execute + db + (conc "ALTER TABLE runs ADD COLUMN " column " " spec))) + ;; correct the entry in the keys column + (sqlite3:execute + db + "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);" + field-num column spec) + ;; fill in blanks (not allowed as it would be part of the path + (sqlite3:execute + db + (conc "UPDATE runs SET " column "='x' WHERE " column "='';")) + (set! field-num (+ field-num 1)))) + fields))) + (define *global-db-store* (make-hash-table)) (define (db:get-access-mode) (if (args:get-arg "-use-db-cache") 'cached 'rmt)) @@ -857,11 +923,11 @@ (define (db:cache-for-read-only source target #!key (use-last-update #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) (let* ((toppath (launch:setup)) - (targ-db-last-mod (if (file-exists? target) + (targ-db-last-mod (if (common:file-exists? target) (file-modification-time target) 0)) (cache-db (or (hash-table-ref/default *global-db-store* target #f) (db:open-megatest-db path: target))) (source-db (db:open-megatest-db path: source)) @@ -871,41 +937,41 @@ (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) (db:sync-tables db:sync-tests-only last-update source-db cache-db) (hash-table-set! *global-db-store* target cache-db) cache-db))) -;; call a proc with a cached db -;; -(define (db:call-with-cached-db proc . params) - ;; first cache the db in /tmp - (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) - (fname (conc (common:get-area-path-signature) ".db")) - (cache-dir (common:get-create-writeable-dir - (list (conc "/tmp/" (current-user-name) "/" cname-part) - (conc "/tmp/" (current-user-name) "-" cname-part) - (conc "/tmp/" (current-user-name) "_" cname-part)))) - (megatest-db (conc *toppath* "/megatest.db"))) - ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) - (if (not cache-dir) - (begin - (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") - (exit 1)) - (let* ((th1 (make-thread - (lambda () - (if (and (file-exists? megatest-db) - (file-write-access? megatest-db)) - (begin - (common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync* - (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) - "call-with-cached-db sync-to-megatest.db")) - (cache-db (db:cache-for-read-only - megatest-db - (conc cache-dir "/" fname) - use-last-update: #t))) - (thread-start! th1) - (apply proc cache-db params) - )))) +;; ;; call a proc with a cached db +;; ;; +;; (define (db:call-with-cached-db proc . params) +;; ;; first cache the db in /tmp +;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) +;; (fname (conc (common:get-area-path-signature) ".db")) +;; (cache-dir (common:get-create-writeable-dir +;; (list (conc "/tmp/" (current-user-name) "/" cname-part) +;; (conc "/tmp/" (current-user-name) "-" cname-part) +;; (conc "/tmp/" (current-user-name) "_" cname-part)))) +;; (megatest-db (conc *toppath* "/megatest.db"))) +;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) +;; (if (not cache-dir) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") +;; (exit 1)) +;; (let* ((th1 (make-thread +;; (lambda () +;; (if (and (common:file-exists? megatest-db) +;; (file-write-access? megatest-db)) +;; (begin +;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* +;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) +;; "call-with-cached-db sync-to-megatest.db")) +;; (cache-db (db:cache-for-read-only +;; megatest-db +;; (conc cache-dir "/" fname) +;; use-last-update: #t))) +;; (thread-start! th1) +;; (apply proc cache-db params) +;; )))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records @@ -915,147 +981,114 @@ ;; 'closeall - close all opened dbs ;; 'schema - attempt to apply schema changes ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) - (if (not (launch:setup)) - (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") - (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (allow-cleanup #t) ;; (if run-ids #f #t)) - (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))) - (data-synced 0)) ;; count of changed records (I hope) - - ;; kill servers - (if (member 'killservers options) - (for-each - (lambda (server) - (match-let (((mod-time host port start-time pid) server)) - (if (and host pid) - (tasks:kill-server host pid)))) - servers)) - - ;; clear out junk records - ;; - (if (member 'dejunk options) - (begin - (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (db:clean-up mtdb) - (db:clean-up tmpdb) - (db:clean-up refndb))) - - ;; adjust test-ids to fit into proper range - ;; - ;; (if (member 'adj-testids options) - ;; (begin - ;; (db:delay-if-busy mtdb) - ;; (db:prep-megatest.db-for-migration mtdb))) - - ;; sync runs, test_meta etc. - ;; - (if (member 'old2new options) - ;; (begin - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) - data-synced))) - ;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) -;; (for-each -;; (lambda (run-id) -;; (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-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 - ;; - (if (member 'new2old options) - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) - data-synced))) - - - - (if (member 'schema options) - (begin - (db:patch-schema-maindb (db:dbdat-get-db mtdb)) - (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) - (db:patch-schema-maindb (db:dbdat-get-db refndb)) - (db:patch-schema-rundb (db:dbdat-get-db mtdb)) - (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) - (db:patch-schema-rundb (db:dbdat-get-db refndb)))) - - ;; (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) - ;; (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 '())) - ;; ;; 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)) -;; (if (member 'schema options) - ;; (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) #f (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 #f (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 -;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) -;; (delete-file fullname))))) -;; dead-runs)))) -;; - ;; (db:close-all dbstruct) - ;; (sqlite3:finalize! mdb) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) - data-synced))) + ;; (if (not (launch:setup)) + ;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") + (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) + (tmpdb (db:get-db dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) + (allow-cleanup #t) ;; (if run-ids #f #t)) + (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))) + (data-synced 0)) ;; count of changed records (I hope) + + (for-each + (lambda (option) + + (case option + ;; kill servers + ((killservers) + (for-each + (lambda (server) + (match-let (((mod-time host port start-time pid) server)) + (if (and host pid) + (tasks:kill-server host pid)))) + servers)) + + ;; clear out junk records + ;; + ((dejunk) + (db:delay-if-busy mtdb) ;; ok to delay on mtdb + (db:clean-up mtdb) + (db:clean-up tmpdb) + (db:clean-up refndb)) + + ;; sync runs, test_meta etc. + ;; + ((old2new) + (set! data-synced + (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) + data-synced))) + + ;; now ensure all newdb data are synced to megatest.db + ;; do not use the run-ids list passed in to the function + ;; + ((new2old) + (set! data-synced + (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) + data-synced))) + + ((adj-target) + (db:adj-target (db:dbdat-get-db mtdb)) + (db:adj-target (db:dbdat-get-db tmpdb)) + (db:adj-target (db:dbdat-get-db refndb))) + + ((schema) + (db:patch-schema-maindb (db:dbdat-get-db mtdb)) + (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) + (db:patch-schema-maindb (db:dbdat-get-db refndb)) + (db:patch-schema-rundb (db:dbdat-get-db mtdb)) + (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) + (db:patch-schema-rundb (db:dbdat-get-db refndb)))) + + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)) + options) + data-synced)) + +(define (db:tmp->megatest.db-sync dbstruct last-update) + (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) + (tmpdb (db:get-db dbstruct)) + (refndb (dbr:dbstruct-refndb dbstruct)) + (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) + (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) + res)) + +;;;; run-ids +;; if #f use *db-local-sync* : or 'local-sync-flags +;; if #t use timestamps : or 'timestamps +;; +;; NB// no-sync-db is the db handle, not a flag! +;; +(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) + (let* ((start-time (current-seconds)) + (last-full-update (if no-sync-db + (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0) + 0)) + (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync + (last-update (if full-sync-needed + 0 + (if no-sync-db + (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) + 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) + (sync-needed (> (- start-time last-update) 6)) + (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds + full-sync-needed) + (begin + (if no-sync-db + (begin + (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time)) + (db:no-sync-set no-sync-db "LAST_UPDATE" start-time))) + (db:tmp->megatest.db-sync dbstruct last-update)) + 0)) + (sync-time (- (current-seconds) start-time))) + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) + (if (common:low-noise-print 30 "sync new to old") + (if sync-needed + (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) + (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) + res)) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...") @@ -1084,11 +1117,11 @@ ((busy) (thread-sleep! sleep-time)) (else (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) @@ -1105,31 +1138,36 @@ (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) - (fieldstr (keys->key/field keys)) + (fieldstr (keys:make-key/field-string configdat)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" - "pass_count")) + "pass_count" "contour")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " - fieldstr (if havekeys "," "") " + ;; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'") + ;; (exit)) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (for-each (lambda (key) + (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + keys) + (sqlite3:execute db (conc + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " + fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', contour TEXT DEFAULT '', state TEXT DEFAULT '', status TEXT DEFAULT '', owner TEXT DEFAULT '', @@ -1137,30 +1175,30 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + (sqlite3:execute db "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 db "CREATE TABLE IF NOT EXISTS run_stats ( + (sqlite3:execute db "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 db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (sqlite3:execute db "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;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', @@ -1169,11 +1207,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -1180,57 +1218,57 @@ testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") - ;; archive disk areas, cached info from [archive-disks] - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + ;; archive disk areas, cached info from [archive-disks] + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( id INTEGER PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; individual bup (or tar) data chunks - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + ;; individual bup (or tar) data chunks + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( id INTEGER PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient - ;; NB// the per run/test recording of where the archive is stored is done in the test - ;; record. - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient + ;; NB// the per run/test recording of where the archive is stored is done in the test + ;; record. + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( id INTEGER PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; move this clean up call somewhere else - (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs - (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + ;; move this clean up call somewhere else + (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - ;; Must do this *after* running patch db !! No more. - ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) - (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) - - ;;====================================================================== - ;; R U N S P E C I F I C D B - ;;====================================================================== - - ;; (define (db:initialize-run-id-db db) - ;; (sqlite3:with-transaction - ;; db - ;; (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + ;; cannot use db:set-var since it will deadlock, hardwire the code here + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) + + ;;====================================================================== + ;; R U N S P E C I F I C D B + ;;====================================================================== + + ;; (define (db:initialize-run-id-db db) + ;; (sqlite3:with-transaction + ;; db + ;; (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1250,18 +1288,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', @@ -1268,18 +1306,18 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1288,34 +1326,34 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) - db)) + db)) ;; ) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== @@ -1347,10 +1385,11 @@ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; @@ -1403,11 +1442,13 @@ res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) - (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) + (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))) + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; (define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) @@ -1448,11 +1489,11 @@ ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) - (dbexists (file-exists? dbpath)) + (dbexists (common:file-exists? dbpath)) (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) @@ -1491,11 +1532,11 @@ (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) - 7200))) ;; two hours + 72000))) ;; twenty hours (db:with-db dbstruct #f #f (lambda (db) (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) @@ -1546,17 +1587,17 @@ ;; 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')); +;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (db:with-db @@ -1604,11 +1645,11 @@ ;; ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) - ;; (dbexists (file-exists? tdatpath))) + ;; (dbexists (common:file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim ;; incompleted)) (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) @@ -1615,11 +1656,12 @@ (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (for-each (lambda (test-id) - (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 + (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828 + all-ids)))))))) ;; ALL REPLACED BY THE BLOCK ABOVE ;; ;; (sqlite3:execute @@ -1671,10 +1713,14 @@ "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" + ;; remove orphaned test_rundat entries + "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);" + ;; + "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);" )))) ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () @@ -1822,10 +1868,87 @@ (define (db:del-var dbstruct var) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) + +;;====================================================================== +;; no-sync.db - small bits of data to be shared between servers +;;====================================================================== + +(define (db:open-no-sync-db) + (let* ((dbpath (db:dbfile-path)) + (dbname (conc dbpath "/no-sync.db")) + (db-exists (common:file-exists? dbname)) + (db (sqlite3:open-database dbname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (if (not db-exists) + (begin + (sqlite3:execute db "PRAGMA synchronous = 0;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") + (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) + db)) + +;; if we are not a server create a db handle. this is not finalized +;; so watch for problems. I'm still not clear if it is needed to manually +;; finalize sqlite3 dbs with the sqlite3 egg. +;; +(define (db:no-sync-db db-in) + (mutex-lock! *db-access-mutex*) + (let ((res (if db-in + db-in + (let ((db (db:open-no-sync-db))) + (set! *no-sync-db* db) + db)))) + (mutex-unlock! *db-access-mutex*) + res)) + +(define (db:no-sync-set db var val) + (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + +(define (db:no-sync-del! db var) + (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) + +(define (db:no-sync-get/default db var default) + (let ((res default)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + (db:no-sync-db db) + "SELECT val FROM no_sync_metadat WHERE var=?;" + var) + (if res + (let ((newres (if (string? res) + (string->number res) + #f))) + (if newres + newres + res)) + res))) + +(define (db:no-sync-close-db db) + (db:safely-close-sqlite3-db db)) + +;; transaction protected lock aquisition +;; either: +;; fails returns (#f . lock-creation-time) +;; succeeds (returns (#t . lock-creation-time) +;; use (db:no-sync-del! db keyname) to release the lock +;; +(define (db:no-sync-get-lock db-in keyname) + (let ((db (db:no-sync-db db-in))) + (sqlite3:with-transaction + db + (lambda () + (handle-exceptions + exn + (let ((lock-time (current-seconds))) + (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)) + `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))) + + ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change @@ -1848,14 +1971,19 @@ ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) #f (let loop ((hed (car header)) - (tal (cdr header)) - (n 0)) - (if (equal? hed field) - (vector-ref row n) + (tal (cdr header)) + (n 0)) + (if (equal? hed field) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field) + #f) + (vector-ref row n)) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;; Accessors for the header/data structure ;; get rows and header from (define (db:get-header vec)(vector-ref vec 0)) @@ -1862,10 +1990,34 @@ (define (db:get-rows vec)(vector-ref vec 1)) ;;====================================================================== ;; R U N S ;;====================================================================== + + + + + +(define (db:get-run-times dbstruct run-patt target-patt) +(let ((res `()) + (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) +;(print qry) +(db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (runname runtime target ) + (set! res (cons (vector runname runtime target) res))) + db + qry + run-patt target-patt) + + res)))) + + (define (db:get-run-name-from-id dbstruct run-id) (db:with-db dbstruct #f ;; this is for the main runs db @@ -1992,10 +2144,48 @@ qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) + +(define-record simple-run target id runname state status owner event_time) +(define-record-printer (simple-run x out) + (fprintf out "#,(simple-run ~S ~S ~S ~S)" + (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) + +;; simple get-runs +;; +(define (db:simple-get-runs dbstruct runpatt count offset target) + (let* ((res '()) + (keys (db:get-keys dbstruct)) + (runpattstr (db:patt->like "runname" runpatt)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (targstr (string-intersperse keys "||'/'||")) + (keystr (conc targstr " AS target," + (string-intersperse remfields ","))) + (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " + ;; Generate: " AND x LIKE 'keypatt' ..." + " AND target LIKE '" target "'" + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) + (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (target id runname state status owner event_time) + (set! res (cons (make-simple-run target id runname state status owner event_time) res))) + db + qrystr + ))) + (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + res)) + ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) @@ -2259,18 +2449,19 @@ (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "area_id")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db - (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") + (conc "SELECT " keystr " FROM runs WHERE id=?;") run-id))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) @@ -2351,11 +2542,11 @@ (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons (list key key-val) res))) + (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db db qry run-id))) keys))) (reverse res))) ;; get key vals for a given run-id @@ -2369,11 +2560,11 @@ (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons key-val res))) + (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db db qry run-id))) keys))) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) @@ -2680,11 +2871,11 @@ (lambda (db) (sqlite3:first-result db ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ... ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');") - "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART') AND run_id=?;" + "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');") ;; NEW BEHAVIOR: Look only at single run with run-id ;; ;; (define (db:get-running-stats dbstruct run-id) @@ -2694,11 +2885,11 @@ run-id #f (lambda (db) (sqlite3:first-result db - "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)))) + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id)))) ;; For a given testname how many items are running? Used to determine ;; probability for regenerating html ;; (define (db:get-count-tests-running-for-testname dbstruct run-id testname) @@ -2951,10 +3142,44 @@ (db:first-result-default db "SELECT rundir FROM tests WHERE id=?;" #f ;; default result test-id)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (test-name item-path test-time target ) + (set! res (cons (vector test-name item-path test-time) res))) + db + qry + run-name target) + res)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (sqlite3:for-each-row + (lambda (test-name item-path test-time target ) + (set! res (cons (vector test-name item-path test-time) res))) + db + qry + run-name target) + res)))) ;;====================================================================== ;; S T E P S ;;====================================================================== @@ -2984,10 +3209,25 @@ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) + + (define (db:get-steps-info-by-id dbstruct test-step-id) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((res (vector #f #f #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile comment) + (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-step-id) + res)))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id @@ -3003,10 +3243,26 @@ (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== + + (define (db:get-data-info-by-id dbstruct test-data-id) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id test-id category variable value expected tol units comment status type ) + (set! res (vector id test-id category variable value expected tol units comment status type))) + db + "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-data-id) + res)))) + ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. @@ -3077,12 +3333,12 @@ (configf:lookup dat entry-name "message") ;; 4 ;; Comment (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status "logpro" ;; 6 ;; Type )))) (let* ((value (or (configf:lookup dat entry-name "measured") "n/a")) - (expected (or (configf:lookup dat entry-name "expected") "n/a")) - (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a")) + (expected (or (configf:lookup dat entry-name "expected") 0.0)) + (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0)) (comment (or (configf:lookup dat entry-name "comment") (configf:lookup dat entry-name "desc") "n/a")) (status (or (configf:lookup dat entry-name "status") "n/a")) (type (or (configf:lookup dat entry-name "expected") "n/a"))) (set! res (append @@ -3183,10 +3439,25 @@ (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))))) + +;; This routine moved from tdb.scm, tdb:read-test-data +;; +(define (db:read-test-data* dbstruct run-id test-id categorypatt varpatt) + (let* ((res '())) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + db + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt) + (reverse res))))) + ;;====================================================================== ;; Misc. test related queries ;;====================================================================== @@ -3302,20 +3573,24 @@ ;; ;; if test-name is an integer work off that instead of test-name test-path ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test + ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met + (let* ((testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id (db:get-test-info dbstruct run-id test-name item-path))) (test-id (db:test-get-id testdat)) (test-name (if (number? test-name) (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) - (tl-test-id (db:test-get-id tl-testdat))) + (tl-test-id (if tl-testdat + (db:test-get-id tl-testdat) + #f))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbstruct 'set-test-start-time (list test-id))) (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f @@ -3325,11 +3600,11 @@ db (lambda () ;; NB// Pass the db so it is part fo the transaction (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item - (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test + (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test (running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) (bad-not-started (length (filter (lambda (x) (and (equal? (dbr:counts-state x) "NOT_STARTED") @@ -3338,52 +3613,120 @@ state-status-counts))) ;; (non-completes (filter (lambda (x) ;; (not (equal? (dbr:counts-state x) "COMPLETED"))) ;; state-status-counts)) (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (cons state (map dbr:counts-state state-status-counts))) - *common:std-states* >)) + (delete-duplicates + (if (not (member state *common:dont-roll-up-states*)) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) (all-curr-statuses (common:special-sort ;; worst -> best (delete-duplicates - (cons status (map dbr:counts-status state-status-counts))) + (if (not (member state *common:dont-roll-up-states*)) + (cons status (map dbr:counts-status state-status-counts)) + (map dbr:counts-status state-status-counts))) *common:std-statuses* >)) (non-completes (filter (lambda (x) - (not (equal? x "COMPLETED"))) + (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) all-curr-states)) + (preq-fails (filter (lambda (x) + (equal? x "PREQ_FAIL")) + all-curr-statuses)) + (num-non-completes (length non-completes)) (newstate (cond - ((> (length non-completes) 0) ;; - (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) - (else - (car all-curr-states)))) + ((> running 0) "RUNNING") ;; anything running, call the situation running + ((> (length preq-fails) 0) + "NOT_STARTED") + ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. + ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED + (else (car all-curr-states)))) ;; (if (> running 0) ;; "RUNNING" ;; (if (> bad-not-started 0) ;; "COMPLETED" ;; (car all-curr-states)))) - (newstatus (if (> bad-not-started 0) - "CHECK" - (car all-curr-statuses)))) + (newstatus (cond + ((> (length preq-fails) 0) + "PREQ_FAIL") + ((or (> bad-not-started 0) + (and (equal? newstate "NOT_STARTED") + (> num-non-completes 0))) + "STARTED") + (else + (car all-curr-statuses))))) + + (debug:print-info 2 *default-log-port* + "\n--> probe db:set-state-status-and-roll-up-items: " + "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) + "\n--> running: "running + "\n--> bad-not-started: "bad-not-started + "\n--> non-non-completes: "num-non-completes + "\n--> non-completes: "non-completes + "\n--> all-curr-states: "all-curr-states + "\n--> all-curr-statuses: "all-curr-statuses + "\n--> newstate "newstate + "\n--> newstatus "newstatus + "\n\n") + ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states) ;; " newstate: " newstate " newstatus: " newstatus) ;; NB// Pass the db so it is part of the transaction - (db:test-set-state-status db run-id tl-test-id newstate newstatus #f))))))) + (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "len(sscs)="(length state-status-counts) " state-status-counts: " + (apply conc + (map (lambda (x) + (conc + (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) + state-status-counts)) + + ); end debug:print + (if tl-test-id + (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct + )))))) + (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) tr-res))))) - -(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:map-row - (lambda (state status count) - (make-dbr:counts state: state status: status count: count)) - db - "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" - run-id test-name item-path)))) +;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* +(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) + + + (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) + (item-state (or item-state-in (db:test-get-state test-info))) + (item-status (or item-status-in (db:test-get-status test-info))) + (other-items-count-recs (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + ;; ignore current item because we have changed its value in the current transation so this select will see the old value. + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" + run-id test-name item-path)))) + + ;; add current item to tally outside of sql query + (match-countrec-lambda (lambda (countrec) + (and (equal? (dbr:counts-state countrec) item-state) + (equal? (dbr:counts-status countrec) item-status)))) + + (already-have-count-rec-list + (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status + + (updated-count-rec (if (null? already-have-count-rec-list) + (make-dbr:counts state: item-state status: item-status count: 1) + (let* ((our-count-rec (car already-have-count-rec-list)) + (new-count (add1 (dbr:counts-count our-count-rec)))) + (make-dbr:counts state: item-state status: item-status count: new-count)))) + + (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec)))) + + (unrelated-rec-list + (filter nonmatch-countrec-lambda other-items-count-recs))) + + (cons updated-count-rec unrelated-rec-list))) ;; (define (db:get-all-item-states db run-id test-name) ;; (sqlite3:map-row ;; (lambda (a) a) ;; db @@ -3719,11 +4062,11 @@ 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))) - (file-exists? dbfj)) + (common:file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) ((5) @@ -3894,10 +4237,11 @@ ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) + ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items (append (if (member 'exclusive mode) (let ((running-tests (db:get-tests-for-run dbstruct #f ;; run-id of #f means for all runs. (if (string=? ref-item-path "") ;; testpatt @@ -3920,72 +4264,125 @@ ;; (conc (db:test-get-testname testdat) ;; "/" ;; (db:test-get-item-path testdat)))) running-tests) ;; calling functions want the entire data '()) + + ;; collection of: for each waiton - + ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: + ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite + ;; if waiton is itemized: + ;; and waiton's items are not expanded, add as unmet prerequisite + ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite + ;; else + ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite + (if (or (not waitons) (null? waitons)) '() - (let* ((unmet-pre-reqs '()) - (result '())) - (for-each + (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) + (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel))))) + (ref-test-is-toplevel (equal? ref-item-path "")) + (ref-test-is-item (not ref-test-is-toplevel)) + (unmet-pre-reqs '()) + (result '()) + (unmet-prereq-items '()) + ) + (for-each ; waitons (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + + (let (;(waiton-is-itemized ...) + ;(waiton-items-are-expanded ...) + (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) - (item-waiton-met #f)) - (for-each - (lambda (test) - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (let* ((state (db:test-get-state test)) - (status (db:test-get-status test)) - (item-path (db:test-get-item-path test)) - (is-completed (equal? state "COMPLETED")) - (is-running (equal? state "RUNNING")) - (is-killed (equal? state "KILLED")) - (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) + (item-waiton-met #f) + + ) + (for-each ; test expanded from waiton + (lambda (waiton-test) + (let* ((waiton-state (db:test-get-state waiton-test)) + (waiton-status (db:test-get-status waiton-test)) + (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath + (waiton-is-toplevel (equal? waiton-item-path "")) + (waiton-is-item (not waiton-is-toplevel)) + (waiton-is-completed (member waiton-state *common:ended-states*)) + (waiton-is-running (member waiton-state *common:running-states*)) + (waiton-is-killed (member waiton-state *common:badly-ended-states*)) + (waiton-is-ok (member waiton-status *common:well-ended-states*)) ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps))) ;; (equal? ref-item-path waiton-item-path))) (set! ever-seen #t) - (cond - ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test of the waiton being examined - is-completed - (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) + ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***") + (cond + ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed + ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed) + (set! parent-waiton-met #t)) + + ;; case 1, non-item (parent test) is + ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined + waiton-is-completed + ;;(BB> "cond1") + (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait)))))) (set! parent-waiton-met #t)) ;; Special case for toplevel and KILLED - ((and (equal? item-path "") ;; this is the parent test - is-killed + ((and waiton-is-toplevel ;; this is the parent test + waiton-is-killed (member 'toplevel mode)) + ;;(BB> "cond2") (set! parent-waiton-met #t)) ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? - ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items - same-itempath) - (if (and is-completed is-ok) - (set! item-waiton-met #t)) - (if (and (equal? item-path "") - (or is-completed is-running));; this is the parent, set it to run if completed or running + ((and ref-test-itemized-mode ref-test-is-item same-itempath) + ;;(BB> "cond3") + (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode)) + (set! item-waiton-met #t) + (set! unmet-prereq-items (cons waiton-test unmet-prereq-items))) + (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set + (or waiton-is-completed waiton-is-running)) (set! parent-waiton-met #t))) ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and is-completed - (or is-ok + ((and waiton-is-completed + (or waiton-is-ok (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok - (set! item-waiton-met #t))))) - tests) + (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT??? + )) + ;;(BB> "cond4") + (set! item-waiton-met #t)) + + ((and waiton-is-completed waiton-is-ok same-itempath) + ;;(BB> "cond5") + (set! item-waiton-met #t)) + (else + #t + ;;(BB> "condelse") + )))) + waiton-tests) ;; both requirements, parent and item-waiton must be met to NOT add item to ;; prereq's not met list - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; appends the string if the full record is not available + ;; (BB> + ;; "\n* waiton-tests "waiton-tests + ;; "\n* parent-waiton-met "parent-waiton-met + ;; "\n* item-waiton-met "item-waiton-met + ;; "\n* ever-seen "ever-seen + ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode + ;; "\n* unmet-prereq-items "unmet-prereq-items + ;; "\n* result (pre) "result + ;; "\n* ever-seen "ever-seen + ;; "\n") + + (cond + ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items))) + (set! result (append unmet-prereq-items result))) + ((not (or parent-waiton-met item-waiton-met)) + (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) + ((not ever-seen) + (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy @@ -4083,12 +4480,12 @@ (testname (vector-ref vb (+ 2 numkeys))) (item-path (vector-ref vb (+ 3 numkeys))) (final-log (vector-ref vb (+ 7 numkeys))) (run-dir (vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (file-exists? log-fpath)) - (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) + (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath)) + (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") "/" runname "/" testname "/" (if (string=? item-path "") "" (conc "/" item-path)) final-log))) @@ -4131,10 +4528,11 @@ (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up + (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -147,10 +147,16 @@ (define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) (define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) (define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) (define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) (define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; S I M P L E R U N +;;====================================================================== + +;; (defstruct id "runname" "state" "status" "owner" "event_time" ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (make-db:test-data)(make-vector 10)) DELETED dbwars/NOTES Index: dbwars/NOTES ================================================================== --- dbwars/NOTES +++ /dev/null @@ -1,31 +0,0 @@ -Before using prepare: - -matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert -Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far) -Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far) -Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far) -create-tests ran register-test 144000 times in 41.0 seconds - -After using prepare: - -matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert -Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far) -Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far) -Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far) -create-tests ran register-test 144000 times in 38.0 seconds - -After moving the prepare outside the call (so it isn't done each time): - -matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert -Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far) -Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far) -Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far) -create-tests ran register-test 144000 times in 33.0 seconds - -Using sql-de-lite with very similar code: - -matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert -Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far) -Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far) -create-tests ran register-test 144000 times in 31.0 seconds - DELETED dbwars/sql-de-lite-test.scm Index: dbwars/sql-de-lite-test.scm ================================================================== --- dbwars/sql-de-lite-test.scm +++ /dev/null @@ -1,19 +0,0 @@ - -(use sql-de-lite) -(include "test-common.scm") - -(define db (open-database "test.db")) - -(exec (sql db test-table-defn)) -(exec (sql db syncsetup)) - -(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) - (exec - stmth ;; (sql db test-insert) - run-id - testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) - -(let ((stmth (sql db test-insert))) - (create-tests stmth)) - -(close-database db) DELETED dbwars/sqlite3-test.scm Index: dbwars/sqlite3-test.scm ================================================================== --- dbwars/sqlite3-test.scm +++ /dev/null @@ -1,20 +0,0 @@ - -(use sqlite3) -(include "test-common.scm") - -(define db (open-database "test.db")) - -(execute db test-table-defn) -(execute db syncsetup) - - -(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) - (execute stmth - run-id - testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) - -(let ((stmth (prepare db test-insert))) - (create-tests stmth) - (finalize! stmth)) - -(finalize! db) DELETED dbwars/test-common.scm Index: dbwars/test-common.scm ================================================================== --- dbwars/test-common.scm +++ /dev/null @@ -1,129 +0,0 @@ -(use srfi-18 srfi-69 apropos) - -(define args (argv)) - -(if (not (eq? (length args) 2)) - (begin - (print "Usage: sqlitecompare [insert|update]") - (exit 0))) - -(define action (string->symbol (cadr args))) - -(system "rm -f test.db") - -(define test-table-defn - "CREATE TABLE IF NOT EXISTS tests - (id INTEGER PRIMARY KEY, - run_id INTEGER, - testname TEXT, - host TEXT DEFAULT 'n/a', - cpuload REAL DEFAULT -1, - diskfree INTEGER DEFAULT -1, - uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', - item_path TEXT DEFAULT '', - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'FAIL', - attemptnum INTEGER DEFAULT 0, - final_logf TEXT DEFAULT 'logs/final.log', - logdat BLOB, - run_duration INTEGER DEFAULT 0, - comment TEXT DEFAULT '', - event_time TIMESTAMP, - fail_count INTEGER DEFAULT 0, - pass_count INTEGER DEFAULT 0, - archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") - -(define test-insert "INSERT INTO tests (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time) - values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );") -(define syncsetup "PRAGMA synchronous = OFF;") - -(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9")) -(define items '()) -(for-each - (lambda (n) - (for-each - (lambda (m) - (set! items (cons (conc "item/" n m) items))) - '(0 1 2 3 4 5 6 7 8 9))) - '(0 1 2 3 4 5 6 7 8 9)) -(define hosts '("host0" "host1" "host2")) ;; "host3" "host4" "host5" "host6" "host7" "host8" "host9")) -(define cpuloads '(0.1 0.2 0.3)) ;; 0.4 0.5 0.6 0.7 0.8 0.9)) -(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000)) -(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux") -(define basedir "/mfs/matt/data/megatest/runs/testing") -(define final-logf "finallog.html") -(define run-durations (list 120 240)) ;; 260)) -(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?")) - -(define run-ids (make-hash-table)) -(define max-run-id 1000) - -(define (test-factors->run-id host cpuload diskfree run-duration comment) - (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment)) - (run-id (hash-table-ref/default run-ids factor #f))) - (if run-id - (list run-id factor) - (let ((new-id (+ max-run-id 1))) - (set! max-run-id new-id) - (hash-table-set! run-ids factor new-id) - (list new-id factor))))) - - -(define (create-tests stmth) - (let ((num-created 0) - (last-print (current-seconds)) - (start-time (current-seconds))) - (for-each - (lambda (test) - (for-each - (lambda (item) - (for-each - (lambda (host) - (for-each - (lambda (cpuload) - (for-each - (lambda (diskfree) - (for-each - (lambda (run-duration) - (for-each - (lambda (comment) - (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment)) - (run-id (car run-id-dat)) - (factor (cadr run-id-dat)) - (curr-time (current-seconds))) - (if (> (- curr-time last-print) 10) - (begin - (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)") - (set! last-print curr-time))) - (set! num-created (+ num-created 1)) - (register-test stmth ;; db - run-id - test ;; testname - host - cpuload - diskfree - uname - (conc basedir "/" test "/" item) ;; rundir - (conc test "/" item) ;; shortdir - item ;; item-path - "NOT_STARTED" ;; state - "NA" ;; status - final-logf - run-duration - comment - (current-seconds)))) - comments)) - run-durations)) - diskfrees)) - cpuloads)) - hosts)) - items)) - tests) - (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds"))) - - - Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -19,11 +19,11 @@ (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) -(declare (uses synchash)) +;; (declare (uses synchash)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -85,185 +85,185 @@ ;; 3. Add extraction of filters to synchash calls ;; ;; NOTE: Used in newdashboard ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) - (let* (;; count and offset => #f so not used - ;; the synchash calls modify the "data" hash - (changed #f) - (get-runs-sig (conc (client:get-signature) " get-runs")) - (get-tests-sig (conc (client:get-signature) " get-tests")) - (get-details-sig (conc (client:get-signature) " get-test-details")) - - ;; test-ids to get and display are indexed on window-id in curr-test-ids hash - (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) - ;; run-id is #f in next line to send the query to server 0 - (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) - (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) - '())) - - ;; Now can calculate the run-ids - (run-hash (hash-table-ref/default data get-runs-sig #f)) - (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - - (all-test-changes (let ((res (make-hash-table))) - (for-each (lambda (run-id) - (if (> run-id 0) - (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) - run-ids) - res)) - (runs-hash (hash-table-ref/default data get-runs-sig #f)) - (header (hash-table-ref/default runs-hash "header" #f)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a header "event_time")) - (time-b (db:get-value-by-header record-b header "event_time"))) - (> time-a time-b))) - )) - (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) - (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) - (colnum 1) - (rownum 0) - (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header -;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) - - ;; tests related stuff - ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) - - ;; Given a run-id and testname/item_path calculate a cell R:C - - ;; NOTE: Also build the test tree browser and look up table - ;; - ;; Each run is unique on its keys and runname or run-id, store in hash on colnum - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) - keys)) - (run-name (db:get-value-by-header run-record header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) - ;; modify cell - but only if changed - (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) - (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (set! colnum (+ colnum 1)))) - run-ids) - - ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table - ;; Do this analysis in the order of the run-ids, the most recent run wins - (for-each (lambda (run-id) - (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id)) - (test-changes (hash-table-ref all-test-changes run-id)) - (new-test-dat (car test-changes)) - (removed-tests (cadr test-changes)) - (tests (sort (map cadr (filter (lambda (testrec) - (eq? run-id (db:mintest-get-run_id (cadr testrec)))) - new-test-dat)) - (lambda (a b) - (let ((time-a (db:mintest-get-event_time a)) - (time-b (db:mintest-get-event_time b))) - (> time-a time-b))))) - ;; test-changes is a list of (( id record ) ... ) - ;; Get list of test names sorted by time, remove tests - (test-names (delete-duplicates (map (lambda (t) - (let ((i (db:mintest-get-item_path t)) - (n (db:mintest-get-testname t))) - (if (string=? i "") - (conc " " i) - n))) - tests))) - (colnum (car (hash-table-ref runid-to-col run-id)))) - ;; for each test name get the slot if it exists and fill in the cell - ;; or take the next slot and fill in the cell, deal with items in the - ;; run view panel? The run view panel can have a tree selector for - ;; browsing the tests/items - - ;; SWITCH THIS TO USING CHANGED TESTS ONLY - (for-each (lambda (test) - (let* ((test-id (db:mintest-get-id test)) - (state (db:mintest-get-state test)) - (status (db:mintest-get-status test)) - (testname (db:mintest-get-testname test)) - (itempath (db:mintest-get-item_path test)) - (fullname (conc testname "/" itempath)) - (dispname (if (string=? itempath "") testname (conc " " itempath))) - (rownum (hash-table-ref/default testname-to-row fullname #f)) - (test-path (append run-path (if (equal? itempath "") - (list testname) - (list testname itempath)))) - (tb (dboard:tabdat-tests-tree data))) - (print "INFONOTE: run-path: " run-path) - (tree:add-node (dboard:tabdat-tests-tree data) "Runs" - test-path - userdata: (conc "test-id: " test-id)) - (let ((node-num (tree:find-node tb (cons "Runs" test-path))) - (color (car (gutils:get-color-for-state-status state status)))) - (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color) - - (set! changed (dcommon:modifiy-if-different - tb - (conc "COLOR" node-num) - color changed)) - - ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) - ) - (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 (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) - dispname - changed)) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) - ;; (conc rownum ":" 0) dispname) - )) - ;; set the cell text and color - ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) - (set! changed (dcommon:modifiy-if-different - (dboard:tabdat-runs-matrix data) - (conc rownum ":" colnum) - (if (member state '("ARCHIVED" "COMPLETED")) - status - state) - changed)) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) - ;; (conc rownum ":" colnum) - ;; (if (member state '("ARCHIVED" "COMPLETED")) - ;; status - ;; state)) - (set! changed (dcommon:modifiy-if-different - (dboard:tabdat-runs-matrix data) - (conc "BGCOLOR" rownum ":" colnum) - (car (gutils:get-color-for-state-status state status)) - changed)) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) - ;; (conc "BGCOLOR" rownum ":" colnum) - ;; (car (gutils:get-color-for-state-status state status))) - )) - tests))) - run-ids) - - (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f))) - (if updater (updater (hash-table-ref/default data get-details-sig #f)))) - - (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:run-update keys data runname keypatts testpatt states statuses mode window-id) +;; (let* (;; count and offset => #f so not used +;; ;; the synchash calls modify the "data" hash +;; (changed #f) +;; (get-runs-sig (conc (client:get-signature) " get-runs")) +;; (get-tests-sig (conc (client:get-signature) " get-tests")) +;; (get-details-sig (conc (client:get-signature) " get-test-details")) +;; +;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash +;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) +;; ;; run-id is #f in next line to send the query to server 0 +;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) +;; (tests-detail-changes (if (not (null? test-ids)) +;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) +;; '())) +;; +;; ;; Now can calculate the run-ids +;; (run-hash (hash-table-ref/default data get-runs-sig #f)) +;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) +;; +;; (all-test-changes (let ((res (make-hash-table))) +;; (for-each (lambda (run-id) +;; (if (> run-id 0) +;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) +;; run-ids) +;; res)) +;; (runs-hash (hash-table-ref/default data get-runs-sig #f)) +;; (header (hash-table-ref/default runs-hash "header" #f)) +;; (run-ids (sort (filter number? (hash-table-keys runs-hash)) +;; (lambda (a b) +;; (let* ((record-a (hash-table-ref runs-hash a)) +;; (record-b (hash-table-ref runs-hash b)) +;; (time-a (db:get-value-by-header record-a header "event_time")) +;; (time-b (db:get-value-by-header record-b header "event_time"))) +;; (> time-a time-b))) +;; )) +;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) +;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) +;; (colnum 1) +;; (rownum 0) +;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header +;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; +;; ;; tests related stuff +;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) +;; +;; ;; Given a run-id and testname/item_path calculate a cell R:C +;; +;; ;; NOTE: Also build the test tree browser and look up table +;; ;; +;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum +;; (for-each (lambda (run-id) +;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) +;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) +;; keys)) +;; (run-name (db:get-value-by-header run-record header "runname")) +;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) +;; (run-path (append key-vals (list run-name)))) +;; (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) +;; ;; modify cell - but only if changed +;; (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) +;; (hash-table-set! runid-to-col run-id (list colnum run-record)) +;; ;; Here we update the tests treebox and tree keys +;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) +;; userdata: (conc "run-id: " run-id)) +;; (set! colnum (+ colnum 1)))) +;; run-ids) +;; +;; ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table +;; ;; Do this analysis in the order of the run-ids, the most recent run wins +;; (for-each (lambda (run-id) +;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id)) +;; (test-changes (hash-table-ref all-test-changes run-id)) +;; (new-test-dat (car test-changes)) +;; (removed-tests (cadr test-changes)) +;; (tests (sort (map cadr (filter (lambda (testrec) +;; (eq? run-id (db:mintest-get-run_id (cadr testrec)))) +;; new-test-dat)) +;; (lambda (a b) +;; (let ((time-a (db:mintest-get-event_time a)) +;; (time-b (db:mintest-get-event_time b))) +;; (> time-a time-b))))) +;; ;; test-changes is a list of (( id record ) ... ) +;; ;; Get list of test names sorted by time, remove tests +;; (test-names (delete-duplicates (map (lambda (t) +;; (let ((i (db:mintest-get-item_path t)) +;; (n (db:mintest-get-testname t))) +;; (if (string=? i "") +;; (conc " " i) +;; n))) +;; tests))) +;; (colnum (car (hash-table-ref runid-to-col run-id)))) +;; ;; for each test name get the slot if it exists and fill in the cell +;; ;; or take the next slot and fill in the cell, deal with items in the +;; ;; run view panel? The run view panel can have a tree selector for +;; ;; browsing the tests/items +;; +;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY +;; (for-each (lambda (test) +;; (let* ((test-id (db:mintest-get-id test)) +;; (state (db:mintest-get-state test)) +;; (status (db:mintest-get-status test)) +;; (testname (db:mintest-get-testname test)) +;; (itempath (db:mintest-get-item_path test)) +;; (fullname (conc testname "/" itempath)) +;; (dispname (if (string=? itempath "") testname (conc " " itempath))) +;; (rownum (hash-table-ref/default testname-to-row fullname #f)) +;; (test-path (append run-path (if (equal? itempath "") +;; (list testname) +;; (list testname itempath)))) +;; (tb (dboard:tabdat-tests-tree data))) +;; (print "INFONOTE: run-path: " run-path) +;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" +;; test-path +;; userdata: (conc "test-id: " test-id)) +;; (let ((node-num (tree:find-node tb (cons "Runs" test-path))) +;; (color (car (gutils:get-color-for-state-status state status)))) +;; (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color) +;; +;; (set! changed (dcommon:modifiy-if-different +;; tb +;; (conc "COLOR" node-num) +;; color changed)) +;; +;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) +;; ) +;; (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 (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) +;; dispname +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc rownum ":" 0) dispname) +;; )) +;; ;; set the cell text and color +;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc rownum ":" colnum) +;; (if (member state '("ARCHIVED" "COMPLETED")) +;; status +;; state) +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc rownum ":" colnum) +;; ;; (if (member state '("ARCHIVED" "COMPLETED")) +;; ;; status +;; ;; state)) +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc "BGCOLOR" rownum ":" colnum) +;; (car (gutils:get-color-for-state-status state status)) +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc "BGCOLOR" rownum ":" colnum) +;; ;; (car (gutils:get-color-for-state-status state status))) +;; )) +;; tests))) +;; run-ids) +;; +;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f))) +;; (if updater (updater (hash-table-ref/default data get-details-sig #f)))) +;; +;; (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))) @@ -313,11 +313,12 @@ (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations (test-name (db:test-get-testname hed)) (item-path (db:test-get-item-path hed)) (state (db:test-get-state hed)) (status (db:test-get-status hed)) - (newitem (list test-name item-path (list test-id state status)))) + (event-time (db:test-get-event_time hed)) + (newitem (list test-name item-path (list test-id state status event-time)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) (define (dcommon:tests-mindat->hash tests-mindat) @@ -333,11 +334,14 @@ ;; 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)) + ((status-goodness-ranking (cdr ;; cdr to drop first item -- "n/a" + (append (map cadr *common:std-statuses*) + '(#f)) ;; algorithm requres last item to be #f + ) ) (mem1 (member status1 status-goodness-ranking)) (mem2 (member status2 status-goodness-ranking)) ) (cond ((and (not mem1) (not mem2)) 0) @@ -491,11 +495,11 @@ (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" + ;; #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) @@ -1185,11 +1189,11 @@ (* scalef 0.01) (* scalef -0.01)))) (if the-cnv (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) )) - ;; #:size "50x50" + ;; #:size "250x250" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) DELETED defunct/multi-dboard.scm Index: defunct/multi-dboard.scm ================================================================== --- defunct/multi-dboard.scm +++ /dev/null @@ -1,801 +0,0 @@ -;;====================================================================== -;; 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)))) - DELETED defunct/nmsg-transport.scm Index: defunct/nmsg-transport.scm ================================================================== --- defunct/nmsg-transport.scm +++ /dev/null @@ -1,358 +0,0 @@ - -;; 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/Makefile ================================================================== --- docs/Makefile +++ docs/Makefile @@ -13,5 +13,7 @@ fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx +pkts.pdf : pkts.dot + dot -Tpdf pkts.dot -o pkts.pdf Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -1015,10 +1015,10 @@

Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,10 +1,12 @@ ASCPATH = $(shell which asciidoc) EXEPATH = $(shell readlink -f $(ASCPATH)) BINPATH = $(shell dirname $(EXEPATH)) DISPATH = $(shell dirname $(BINPATH)) +SRCFSL = $(shell fossil info | grep repository: | awk '{print $$2}') +INPAGES = plan.in howto.in reference.in getting_started.in # broad_goals.csv needed_features.csv : tables/*.dat # ./refdb2csv tables # in a makefile recipe, $< denotes the first dependency; $@ the target @@ -13,15 +15,15 @@ # 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 installation.txt *png +megatest_manual.html : megatest_manual.txt $(INPAGES) writing_tests.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 +megatest.pdf : megatest_manual.txt $(INPAGES) writing_tests.txt *png a2x -a toc -f pdf megatest_manual.txt server.ps : server.dot dot -Tps server.dot > server.ps @@ -30,7 +32,13 @@ complex-itemmap.png : complex-itemmap.dot dot -Tpng complex-itemmap.dot -o complex-itemmap.png dot -Tpdf complex-itemmap.dot -o complex-itemmap.pdf +%.in : $(SRCFSL) + fossil wiki export $* $*.in + +# %.txt : %.in +# cp $*.in $*.txt + clean: rm -f megatest_manual.html Index: docs/manual/complex-itemmap.dot ================================================================== --- docs/manual/complex-itemmap.dot +++ docs/manual/complex-itemmap.dot @@ -38,10 +38,10 @@ label = "Test E"; "C/1/bb" -> "E/1/res"; "C/2/bb" -> "E/2/res"; } - label = "Complex Itemmapping"; + label = "Complex Itemmapping (arrows indicate order of execution)"; color=green; } } Index: docs/manual/complex-itemmap.png ================================================================== --- docs/manual/complex-itemmap.png +++ docs/manual/complex-itemmap.png cannot compute difference between binary files DELETED docs/manual/getting_started.txt Index: docs/manual/getting_started.txt ================================================================== --- docs/manual/getting_started.txt +++ /dev/null @@ -1,99 +0,0 @@ - -Getting Started ---------------- - -[partintro] -.Getting started with Megatest --- -Creating a testsuite or flow and your first test or task. --- - -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 ----------------- DELETED docs/manual/howto.txt Index: docs/manual/howto.txt ================================================================== --- docs/manual/howto.txt +++ /dev/null @@ -1,192 +0,0 @@ - -How To Do Things ----------------- - -Process Runs -~~~~~~~~~~~~ - -Remove Runs -^^^^^^^^^^^ - -From the dashboard click on the button (PASS/FAIL...) for one of the tests. From the test control panel that -comes up push the clean test button. The command field will be prefilled with a template command for removing -that test. You can edit the command, for example change the argument to -testpatt to "%" to remove all tests. - -.Remove the test diskperf and all it's items ----------------- -megatest -remove-runs -target ubuntu/nfs/none -runname ww28.1a -testpatt diskperf/% -v ----------------- - -.Remove all tests for all runs and all targets ----------------- -megatest -remove-runs -target %/%/% -runname % -testpatt % -v ----------------- - -Archive Runs -^^^^^^^^^^^^ - -Megatest supports using the bup backup tool (https://bup.github.io/) to archive your tests for efficient storage -and retrieval. Archived data can be rapidly retrieved if needed. The metadata for the run (PASS/FAIL status, run -durations, time stamps etc.) are all preserved in the megatest database. - -For setup information see the Archiving topic in the reference section of this manual. - -To Archive -++++++++++ - -Hint: use the test control panel to create a template command by pushing the "Archive Tests" button. - -.Archive a full run ----------------- -megatest -target ubuntu/nfs/none -runname ww28.1a -archive save-remove -testpatt % ----------------- - -To Restore -++++++++++ - -.Retrieve a single test ----------------- -megatest -target ubuntu/nfs/none -runname ww28.1a -archive restore -testpatt diskperf/% ----------------- - -Hint: You can browse the archive using bup commands directly. - ----------------- -bup -d /path/to/bup/archive ftp ----------------- - -Submit jobs to Host Types based on Test Name -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.In megatest.config ------------------------- -[host-types] -general ssh #{getbgesthost general} -nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo - -[hosts] -general cubian xena - -[launchers] -envsetup general -xor/%/n 4C16G -% nbgeneral - -[jobtools] -launcher bsub -# if defined and not "no" flexi-launcher will bypass launcher unless there is no -# match. -flexi-launcher yes ------------------------- - -Tricks ------- - -This section is a compendium of a various useful tricks for debugging, -configuring and generally getting the most out of Megatest. - -Limiting your running jobs -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously. - -In your testconfig: - ----------------- -[test_meta] -jobgroup group1 ----------------- - -In your megatest.config: - ---------------- -[jobgroups] -group1 10 -custdes 4 ---------------- - -Debugging Tricks ----------------- - -Examining The Environment -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Test Control Panel - xterm -^^^^^^^^^^^^^^^^^^^^^^^^^^ - -From the dashboard click on a test PASS/FAIL button. This brings up a test control panel. Aproximately near the center left of the -window there is a button "Start Xterm". Push this to get an xterm with the full context and environment loaded for that test. You can run -scripts or ezsteps by copying from the testconfig (hint, load up the testconfig in a separate gvim or emacs window). This is the easiest way -to debug your tests. - -During Config File Processing -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -It is often helpful to know the content of variables in various -contexts as Megatest does the actions needed to run your tests. A handy technique is to force the startup of an xterm in the context being examined. - -For example, if an item list is not being generated as expected you -can inject the startup of an xterm as if it were an item: - -.Original items table ------------------ -[items] -CELLNAME [system getcellname.sh] ------------------ - -.Items table modified for debug ------------------ -[items] -DEBUG [system xterm] -CELLNAME [system getcellnames.sh] ------------------ - -When this test is run an xterm will pop up. In that xterm the -environment is exactly that in which the script "getcellnames.sh" -would run. You can now debug the script to find out why it isn't -working as expected. - -Organising Your Tests and Tasks -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -The default location "tests" for storing tests can be extended by -adding to your tests-paths section. - ----------------------------- -[misc] -parent #{shell dirname $(readlink -f .)} - -[tests-paths] -1 #{get misc parent}/simplerun/tests ----------------------------- - -The above example shows how you can use addition sections in your -config file to do complex processing. By putting results of relatively -slow operations into variables the processing of your configs can be -kept fast. - -Alternative Method for Running your Job Script -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -.Directly running job in testconfig -------------------- -[setup] -runscript main.csh -------------------- - -The runscript method is essentially a brute force way to run scripts where the -user is responsible for setting STATE and STATUS and managing the details of running a test. - -Debugging Server Problems -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Some handy Unix commands to track down issues with servers not -communicating with your test manager processes. Please put in tickets -at https://www.kiatoa.com/fossils/megatest if you have problems with -servers getting stuck. - ----------------- -sudo lsof -i -sudo netstat -lptu -sudo netstat -tulpn ----------------- 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:css-jscript-block-dynamic +#< +EOF +) + +(define (test:js-block javascript-lib) + (conc "" )) + + +(define tests:css-jscript-block-static (test:js-block *java-script-lib*)) + +(define (tests:css-jscript-block-cond dynamic) + (if (equal? dynamic #t) + tests:css-jscript-block-dynamic + tests:css-jscript-block-static)) + + (define (tests:run-record->test-path run numkeys) (append (take (vector->list run) numkeys) (list (vector-ref run (+ 1 numkeys))))) @@ -709,57 +770,33 @@ (hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path)))) test-data))) runs) resh)) -;; (tests:create-html-tree "test-index.html") +;; tests:genrate dashboard body ;; -(define (tests:create-html-tree outf) - (let* ((lockfile (conc outf ".lock")) - (runs-to-process '()) - (linktree (common:get-linktree)) - (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) - (numkeys (length keys)) - (total-runs (rmt:get-num-runs "%")) - (pg-size 10) ) - (if (common:simple-file-lock lockfile) - (begin - (print total-runs) - (let loop ((page 0)) - (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) - (start (* page pg-size)) + +(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag) + (let* ((start (* page pg-size)) (runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) (header (vector-ref runsdat 0)) (runs (vector-ref runsdat 1)) (ctr 0) (test-runs-hash (tests:get-rest-data runs header numkeys)) (test-list (hash-table-keys test-runs-hash)) - (get-prev-links (lambda (page linktree ) - (let* ((link (if (not (eq? page 0)) - (s:a "<<prev" 'href (conc linktree "/page" (- page 1) ".html")) - (s:a "" 'href (conc linktree "/page" page ".html"))))) - link))) - (get-next-links (lambda (page linktree total-runs) - (let* ((link (if (> total-runs (+ 1 (* page pg-size))) - (s:a "next>>" 'href (conc linktree "/page" (+ page 1) ".html")) - (s:a "" 'href (conc linktree "/page" page ".html"))))) - link)))) - (s:output-new - oup - (s:html tests:css-jscript-block + ) + (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag) (s:title "Summary for " area-name) (s:body 'onload "addEvents();" (get-prev-links page linktree) (get-next-links page linktree total-runs) (s:h1 "Summary for " area-name) (s:h3 "Filter" ) (s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()") - ;; top list - (s:table 'id "LinkedList1" 'border "1" + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 (map (lambda (key) (let* ((res (s:tr 'class "something" (s:th key ) (map (lambda (run) (s:th (vector-ref run ctr))) @@ -782,32 +819,308 @@ (map (lambda (run) (let* ((run-test (hash-table-ref/default item-hash item-name #f)) (run-id (db:get-value-by-header run header "id")) (result (hash-table-ref/default run-test run-id "n/a")) (status (if (string? result) - (begin - ; (print "string" result) - result) - (begin - ; (print "not string" result ) - (car result))))) - (s:td status 'class status))) + result + (car result))) + (link (if (string? result) + result + (if (equal? flag #t) + (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name )) + (s:a (car result) 'href (cadr result)))))) + (s:td link 'class status))) runs)))) res)) item-keys))) - test-list))))) + test-list)))))) + +;; (tests:create-html-tree "test-index.html") +;; +(define (tests:create-html-tree outf) + (let* ((lockfile (conc outf ".lock")) + (runs-to-process '()) + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (total-runs (rmt:get-num-runs "%")) + (pg-size 10)) + (if (common:simple-file-lock lockfile) + (begin + ;(print total-runs) + (let loop ((page 0)) + (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) + (get-prev-links (lambda (page linktree ) + (let* ((link (if (not (eq? page 0)) + (s:a "<<prev" 'href (conc linktree "/page" (- page 1) ".html")) + (s:a "" 'href (conc linktree "/page" page ".html"))))) + link))) + (get-next-links (lambda (page linktree total-runs) + (let* ((link (if (> total-runs (+ 10 (* page pg-size))) + (s:a "next>>" 'href (conc linktree "/page" (+ page 1) ".html")) + (s:a "" 'href (conc linktree "/page" page ".html"))))) + link))) ) + ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name)) + (s:output-new + oup + (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f)) (close-output-port oup) ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) #f))) +(define (tests:readlines filename) + (call-with-input-file filename + (lambda (p) + (let loop ((line (read-line p)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line p) (cons line result))))))) + +(define (tests:get-test-log run-id test-name item-name) + (let* ((test-data (rmt:get-tests-for-run + (string->number run-id) + test-name ;; 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)) + (path "") + (found 0)) + (debug:print-info 0 *default-log-port* "found: " found ) + + (let loop ((hed (car test-data)) + (tal (cdr test-data))) + (debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13)) + + (if (equal? (vector-ref hed 11) item-name) + (begin + (set! found 1) + (set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13))))) + (if (and (not (null? tal)) (equal? found 0)) + (loop (car tal)(cdr tal)))) + (if (equal? path "") + "

Data not found

" + (string-join (tests:readlines path) "\n")))) + + +(define (tests:dynamic-dboard page) +;(define (tests:create-html-tree o) + (let* ( +;(page "1") + (linktree (common:get-linktree)) + (area-name (common:get-testsuite-name)) + (keys (rmt:get-keys)) + (numkeys (length keys)) + (total-runs (rmt:get-num-runs "%")) + (pg-size 10) + (pg (if (equal? page #f) + 0 + (- (string->number page) 1))) + (get-prev-links (lambda (pg linktree) + (debug:print-info 0 *default-log-port* "val: " (- 1 pg)) + (let* ((link (if (not (eq? pg 0)) + (s:a "<<prev " 'href (conc "dashboard?page=" pg )) + (s:a "" 'href (conc "dashboard?page=" pg))))) + link))) + (get-next-links (lambda (pg linktree total-runs) + (debug:print-info 0 *default-log-port* "val: " pg) + (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size) + + (let* ((link (if (> total-runs (+ 10 (* pg pg-size))) + (s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) )) + (s:a "" 'href (conc "dashboard?page=" pg ))))) + link))) + (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t))) + ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name)) +html-body)) + +(define (tests:create-html-summary outf) + (let* ((lockfile (conc outf ".lock")) + (linktree (common:get-linktree)) + (keys (rmt:get-keys)) + (area-name (common:get-testsuite-name))) + (if (common:simple-file-lock lockfile) + (begin + (let* ((runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (runs (vector-ref runsdat 1)) + (header (vector-ref runsdat 0)) + (oup (open-output-file (or outf (conc linktree "/targets.html")))) + (target-hash (test:create-target-hash runs header (length keys)))) + (test:create-target-html target-hash oup area-name linktree) + (test:create-run-html runs area-name linktree (length keys) header)) + (common:simple-file-release-lock lockfile)) + #f))) + +(define (test:get-test-hash test-data) + (let ((resh (make-hash-table))) + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html")) + (conc (vector-ref test 10) "/test-summary.html" ) + (conc (vector-ref test 10) "/" (vector-ref test 13)))) + (test-item (vector-ref test 11)) + (test-status (vector-ref test 4))) + (if (not (hash-table-ref/default resh test-item #f)) + (hash-table-set! resh test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path)))) + test-data) +resh)) + +(define (test:get-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + + +(define (test:create-run-html runs area-name linktree numkeys header) + (map (lambda (run) + (let* ((target (string-join (take (vector->list run) numkeys) "/")) + (run-name (db:get-value-by-header run header "runname")) + (run-time (seconds->work-week/day-time (db:get-value-by-header run header "event_time"))) + (oup (open-output-file (conc linktree "/" target "/" run-name "/run.html"))) + (run-id (db:get-value-by-header run header "id")) + (test-data (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)) + (item-test-hash (test:get-test-hash test-data)) + (items (hash-table-keys item-test-hash)) + (test-names (test:get-data->b-keys item-test-hash items))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Runs View " run-name) + (s:body + (s:h1 "Runs View " ) + (s:h3 "Target" target) + (s:p + (s:b "Run name" ) run-name) + (s:p + (s:b "Run Date" ) run-time) + + + (s:table 'border 1 'cellspacing 0 + (s:tr + (s:th "Items") + (map (lambda (test) + (s:th test)) + test-names)) + (map (lambda (item) + (let* ((test-hash (hash-table-ref/default item-test-hash item #f))) + (if test-hash + (begin + (s:tr + (s:td 'class "test" item) + (map (lambda (test) + (let* ((test-details (hash-table-ref/default test-hash test #f)) + (status (if test-details + (car test-details))) + (link (if test-details + (cadr test-details)))) + (if test-details + (s:td 'class status + (s:a 'class "link" 'href link status )) + (s:td "")))) + test-names)))))) + (sort items string<=?)))))) + (close-output-port oup))) +runs)) + +(define (test:create-target-hash runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (db:get-value-by-header run header "runname")) + (target (string-join (take (vector->list run) numkeys) "/")) + (run-list (hash-table-ref/default resh target #f))) + + (if (not run-list) + (hash-table-set! resh target (list run-name)) + (hash-table-set! resh target (cons run-name run-list))))) + runs) + resh)) + +(define (test:get-max-run-cnt target-hash targets) + (let* ((cnt 0 )) + (map (lambda (target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (run-length (if runs + (length runs) + 0))) + + (if (< cnt run-length) + (set! cnt run-length)))) + targets) +cnt)) + +(define (test:pad-runs target-hash targets max-row-length) + (map (lambda (target) + (let loop ((run-list (hash-table-ref/default target-hash target #f))) + (if (< (length run-list) max-row-length) + (begin + (hash-table-set! target-hash target (cons "" run-list)) + (loop (hash-table-ref/default target-hash target #f) ))))) + targets) + target-hash) +(define (test:create-target-html target-hash oup area-name linktree) + (let* ((targets (hash-table-keys target-hash)) + (max-row-length (test:get-max-run-cnt target-hash targets)) + (pad-runs-hash (test:pad-runs target-hash targets max-row-length))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + (s:title "Target View " area-name) + (s:body + (s:h1 "Target View " area-name) + (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0 + (s:tr 'class "something" + (s:th "Target") + (s:th 'colspan max-row-length "Runs")) + (let* ((tbl (map (lambda (target) + (s:tr + (s:td 'class "test" target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (rest-row (map (lambda (run) + (if (equal? run "") + (s:td run) + (s:td + (s:a 'href (conc linktree "/" target "/" run "/run.html") run)))) + (reverse runs)))) + rest-row))) + targets))) + tbl))))) + (close-output-port oup))) (define (tests:create-html-tree-old outf) (let* ((lockfile (conc outf ".lock")) (runs-to-process '())) @@ -839,11 +1152,11 @@ '() (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) + (if (and (common: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") @@ -878,11 +1191,11 @@ 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) + (oup (if (and (common: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) @@ -906,21 +1219,21 @@ (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) + (html-file (if (common:file-exists? alt-file) alt-file std-file)) (run-name (car (reverse p)))) - (if (and (not (file-exists? full-targ)) + (if (and (not (common: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) + (if (common: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))))) )))))) @@ -1075,11 +1388,11 @@ (s:td "status") (s:td (s:a 'href logf (s:font 'color color status)))) (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time (db:test-get-event_time test-dat))) (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) (s:h3 "Log files") - (s:table + (s:table 'cellspacing "0" 'border "1" (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) (s:table 'cellspacing "0" 'border "1" (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) @@ -1129,11 +1442,11 @@ ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) ;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) -;; (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) +;; (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests)) ;; (delete-duplicates ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) @@ -1146,28 +1459,29 @@ (getenv "MT_TEST_NAME") (getenv "MT_ITEMPATH")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") "/" - (if (or (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")))) + (getenv "MT_TEST_NAME") + (if (and (getenv "MT_ITEMPATH") + (not (string=? "" (getenv "MT_ITEMPATH")))) + (conc "/" (getenv "MT_ITEMPATH")) + "")) #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; -(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)) (let* ((use-cache (common:use-cache?)) (cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read - (file-exists? cache-file))) + (common:file-exists? cache-file))) (cached-dat (if (and (not force-create) cache-exists use-cache) (handle-exceptions exn @@ -1187,11 +1501,11 @@ (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + (testexists (and (common:file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) @@ -1198,11 +1512,12 @@ #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file - (file-write-access? cache-path)) + (file-write-access? cache-path) + allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (not (common:in-running-test?)) (configf:write-alist tcfg tpath)))) tcfg)))))) @@ -1356,11 +1671,11 @@ ;; (define (tests:lazy-dot testrecords outtype sizex sizey) (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) (tests:write-dot-file testrecords dfile sizex sizey) - (if (file-exists? fname) + (if (common:file-exists? fname) (let ((res (with-input-from-file fname (lambda () (read-lines))))) (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&")) res) @@ -1559,11 +1874,11 @@ (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up") (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -173,11 +173,11 @@ cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config build - mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 + mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 fullrun/logs rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% Index: tests/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -3,34 +3,26 @@ RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines # max_concurrent_jobs 150 -max_concurrent_jobs 1000 +max_concurrent_jobs 3000 # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks} [include testqa/configs/megatest.abc.config] -# timeout 0.025 - [jobtools] maxload 4 -launcher nbfake +# launcher smartlauncher --cores 1 --memory 1 +launcher nbjob run --target pdx_soft --class 'SLES11&&1C&&1G' --qslot /icf/fdk/soft +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log [server] # timeout 0.01 # homehost xena # homehost 143.182.225.38 - # force server -server-query-threshold 0 - - -[jobtools] -# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk -launcher nbfake -maxload 4 - -# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log +# server-query-threshold 0 + Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -3,22 +3,23 @@ MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard NEWDASHBOARD = $(BINDIR)/newdashboard RUNNAME = a NUMTESTS = 20 +SUBTARG = b all : $(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/% $(MEGATEST) -run -testpatt % -target a/b -runname c bigbig : for tn in a b c d;do \ - ($(MEGATEST) -run -testpatt % -target a/b -runname $tn & ) ; \ + (NUMTESTS=1000 $(MEGATEST) -run -testpatt % -target a/$(SUBTARG) -runname $$tn & ) ; \ done waitonpatt : - megatest -remove-runs -runname waitonpatt -target a/b -testpatt % + megatest -remove-runs -runname waitonpatt -target a/$(SUBTARG) -testpatt % NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8 waitonall : megatest -remove-runs -runname waitonall -target a/b -testpatt % NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,12 +1,18 @@ [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # launchwait no +# launch-delay 0.1 launch-delay 0 +[jobtools] +maxhomehostload 4 + [server] -runtime 180 +# runtime 180 +# timeout is in hours, this is how long the server will stay alive when not being used. +# timeout 0.1 # All these are overridden in ../fdk.config # [jobtools] # launcher nbfake # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log Index: tests/fdktestqa/testqa/runconfigs.config ================================================================== --- tests/fdktestqa/testqa/runconfigs.config +++ tests/fdktestqa/testqa/runconfigs.config @@ -1,5 +1,7 @@ +[include local.runconfigs] + [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] [SYSTEM_val/RELEASE_val] Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -9,11 +9,11 @@ mode itemwait itemmap .*/ # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map (lambda (x)(conc "blah/" x)) \ +NUMBER #{scheme (string-intersperse (map (lambda (x)(conc (if (getenv "USEBLAH") "blah/" "") x)) \ (map number->string (sort (let loop ((a 0)(res '())) \ (if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500)) \ (loop (+ a 1)(cons a res)) res)) <))) " ")} Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -47,11 +47,13 @@ waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 # wait 0.5 seconds between launching every process # -launch-delay 0.5 +# launch-delay 0.5 +launch-delay 0 + # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses @@ -252,10 +254,12 @@ # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log # launcher #{ shell if which bsub > /dev/null;then echo bsub -q priority -o openlava.log;else echo sleeprunner;fi} # launcher nbfake +maxload 1.1 +maxhomehostload 1.1 [configf:settings trim-trailing-spaces yes] # Override the rollup for specific tests [testrollup] Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,10 +1,10 @@ [default] SOMEVAR This should show up in SOMEVAR3 VARNOVAL VARNOVAL_WITHSPACE -QUICK % +QUICKPATT test_mt_vars,test2,priority_9 # target based getting of config file, look at afs.config and nfs.config [include #{getenv fsname}.config] [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] ADDED tests/fullrun/test-teamcity-run.sh Index: tests/fullrun/test-teamcity-run.sh ================================================================== --- /dev/null +++ tests/fullrun/test-teamcity-run.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +(cd ../..;make install) && RN=tcmt_m;megatest -remove-runs -target ubuntu/nfs/none -runname tcmt_m -testpatt %;\ + tcmt -run -target ubuntu/nfs/none -runname tcmt_m -testpatt % -rerun-clean 2>&1 | tee all.log | grep teamcity | tee teamcity.log + Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -17,10 +17,26 @@ (import srfi-18) ;; (require-extension zmq) ;; (import zmq) (define test-work-dir (current-directory)) + +;; given list of lists +;; ( ( msg expected param1 param2 ...) +;; ( ... ) ) +;; apply test to all +;; +(define (test-batch proc pname inlst #!key (post-proc #f)) + (for-each + (lambda (spec) + (let ((msg (conc pname " " (car spec))) + (result (cadr spec)) + (params (cddr spec))) + (if post-proc + (test msg result (post-proc (apply proc params))) + (test msg result (apply proc params))))) + inlst)) ;; read in all the _record files (let ((files (glob "*_records.scm"))) (for-each (lambda (file) Index: tests/unittests/all-rmt.scm ================================================================== --- tests/unittests/all-rmt.scm +++ tests/unittests/all-rmt.scm @@ -28,13 +28,25 @@ ;; DEF (rmt:kill-server run-id) ;; DEF (rmt:start-server run-id) (test #f '(#t "successful login")(rmt:login #f)) ;; DEF (rmt:login-no-auto-client-setup connection-info) (test #f #t (pair? (rmt:get-latest-host-load (get-host-name)))) + +;; get-latest-host-load does a lookup in the db, it won't return a useful value unless +;; a test ran recently on host +(test-batch rmt:get-latest-host-load + "rmt:get-latest-host-load" + (list (list "localhost" #t (get-host-name)) + (list "not-a-host" #t "not-a-host" )) + post-proc: pair?) + (test #f #t (list? (rmt:get-changed-record-ids 0))) + (test #f #f (begin (runs:update-all-test_meta #f) #f)) + (test #f '("test1" "test2")(sort (alist-ref "tagtwo" (hash-table->alist (rmt:get-tests-tags)) equal?) string<=)) + (test #f '() (rmt:get-key-val-pairs 0)) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys-write)) ;; dummy query to force server start (test #f '() (rmt:get-key-vals 1)) (test #f (vector '("SYSTEM" "RELEASE") '()) (rmt:get-targets)) @@ -82,11 +94,27 @@ (test #f '()(rmt:get-prev-run-ids 1)) (test #f #t (begin (rmt:lock/unlock-run 1 #t #f "mikey") #t)) (test #f "JUSTFINE" (rmt:get-run-status 1)) (test #f #t (begin (rmt:set-run-status 1 "NOTFINE" msg: "A message") #t)) (test #f #t (begin (rmt:update-run-event_time 1) #t)) + ;; (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default +;; +(let ((keys (rmt:get-keys)) + (rnp "%") ;; run name patt + (tpt "%/%")) ;; target patt + (test-batch rmt:get-runs-by-patt + "rmt:get-runs-by-patt" + (list (list "t=0" #t keys rnp tpt #f #f #f 0) + (list "t=current" #f keys rnp tpt #f #f #f (+ 100 (current-seconds))) ;; should be no records from the future + ) + post-proc: (lambda (res) + ;; (print "rmt:get-runs-by-patt returned: " res) + (and (vector? res) + (let ((rows (vector-ref res 1))) + (> (length rows) 0)))))) + ;; (rmt:find-and-mark-incomplete run-id ovr-deadtime) ;; (rmt:get-main-run-stats run-id) ;; (rmt:get-var varname) ;; (rmt:set-var varname value) ;; (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) Index: tests/unittests/tests.scm ================================================================== --- tests/unittests/tests.scm +++ tests/unittests/tests.scm @@ -12,67 +12,70 @@ ;; (non-completed (runs:calc-not-completed prereqs-not-met)) ;; (runnables (runs:calc-runnable prereqs-not-met))) ;; ;; ;; - (define user (current-user-name)) (define runname "mytestrun") (define keys (rmt:get-keys)) (define runinfo #f) (define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) +(define contour #f) (define run-id 1) - +(define new-comment #f) ;; Create a run -(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user contour)) (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) (test #f #t (rmt:general-call 'register-test run-id run-id "test-two" "")) (test #f #t (rmt:general-call 'register-test run-id run-id "test-three" "")) (test #f #t (rmt:general-call 'register-test run-id run-id "test-four" "")) -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" "") -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" "") -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" "") -(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" "") + +;; (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" new-comment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" new-comment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" new-comment) +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" new-comment) -(print "MODE=not in") -(test #f '() +(test "MODE=not in" + '() (filter (lambda (y) (equal? y "FAIL")) ;; any FAIL in the output list? (map (lambda (x)(vector-ref x 4)) (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard)))) -(print "MODE=in") -(test #f '("FAIL") +(test "MODE=in" + '("FAIL") (map (lambda (x)(vector-ref x 4)) (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) -(print "MODE=in, state in RUNNING") ;; (set! *verbosity* 8) -(test #f '("RUNNING") +(test "MODE=in, state in RUNNING" '("RUNNING") (map (lambda (x)(vector-ref x 3)) (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '() #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) -(print "MODE=in, state in RUNNING and status IN WARN") ;; (set! *verbosity* 8) -(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) - (map - (lambda (x) - (cons (vector-ref x 3)(vector-ref x 4))) - (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +;;(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) +(test + "MODE=in, state in RUNNING and status IN WARN" + '(("COMPLETED" . "WARN") ("RUNNING" . "n/a") ) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) -(print "MODE=not in, state in RUNNING and status IN WARN") (set! *verbosity* 8) -(test #f '(("DELETED" . "n/a") ("COMPLETED" . "PASS") ("COMPLETED" . "FAIL")) +(test "MODE=not in, state in RUNNING and status IN WARN" + '(("COMPLETED" . "PASS") ("COMPLETED" . "FAIL")) (map (lambda (x) (cons (vector-ref x 3)(vector-ref x 4))) (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard))) (set! *verbosity* 1) DELETED testzmq/hwclient.scm Index: testzmq/hwclient.scm ================================================================== --- testzmq/hwclient.scm +++ /dev/null @@ -1,16 +0,0 @@ -(use zmq posix srfi-18) - -(define s (make-socket 'req)) -(connect-socket s "tcp://*:5563") - -(define myname (cadr (argv))) - -(print "Start client...") - -(do ((i 0 (+ i 1))) - ((>= i 1000)) - (print "sending message #" i) - (send-message s (conc "Hello from " myname)) - (print "sent \"Hello\", looking for a reply") - (printf "Received reply ~a [~a]\n" - i (receive-message s))) DELETED testzmq/hwserver.scm Index: testzmq/hwserver.scm ================================================================== --- testzmq/hwserver.scm +++ /dev/null @@ -1,28 +0,0 @@ -(use zmq srfi-18 posix) - -(define th1 (make-thread - (lambda () - (let ((s (make-socket 'rep))) - (bind-socket s "tcp://*:5563") - (print "Start server...") - (let loop () - (let* ((msg (receive-message s)) - (name (caddr (string-split msg " "))) - (resp (conc "World " name))) - (print "Received request: [" msg "]") - (thread-sleep! 0.0001) - (print "Sending response \"" resp "\"") - (send-message s resp) - (loop))))))) -(define th2 (make-thread - (lambda () - (let loop ((count 0)) - (print "count is " count) - (thread-sleep! 0.1) - (if (< count 10000) - (loop (+ count 1))))))) - -(thread-start! th1) -(thread-start! th2) - -(thread-join! th1) DELETED testzmq/hwtest.sh Index: testzmq/hwtest.sh ================================================================== --- testzmq/hwtest.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/bash - -echo Compiling hwclient and hwserver -csc hwclient.scm -csc hwserver.scm - -./hwserver > hwserver.log & - -sleep 1 -for x in a b c d e f g h i j k l m n o p q r s t u v w x y z;do -./hwclient $x & -done - -# killall -v hwserver hwclient DELETED testzmq/mockupclient.scm Index: testzmq/mockupclient.scm ================================================================== --- testzmq/mockupclient.scm +++ /dev/null @@ -1,42 +0,0 @@ -(use zmq posix numbers) - -(define cname "Bob") -(define runtime 10) -(let ((args (argv))) - (if (< (length args) 3) - (begin - (print "Usage: mockupclient clientname runtime") - (exit)) - (begin - (set! cname (cadr args)) - (set! runtime (string->number (caddr args)))))) - -;; (define start-delay (/ (random 100) 9)) -;; (define runtime (+ 1 (/ (random 200) 2))) - -(print "Starting client " cname " with runtime " runtime) - -(include "mockupclientlib.scm") - -(set! endtime (+ (current-seconds) runtime)) - -;; first ping the server to ensure we have a connection -(if (server-ping cname 5) - (print "SUCCESS: Client " cname " connected to server") - (begin - (print "ERROR: Client " cname " failed ping of server, exiting") - (exit))) - -(let loop () - (let ((x (random 15)) - (varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4)))) - (case x - ;; ((1)(dbaccess cname 'sync "nodat" #f)) - ((2 3 4 5)(dbaccess cname 'set varname (random 999))) - ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f))) - (else - (thread-sleep! 0.011))) - (if (< (current-seconds) endtime) - (loop)))) - -(print "Client " cname " all done!!") DELETED testzmq/mockupclientlib.scm Index: testzmq/mockupclientlib.scm ================================================================== --- testzmq/mockupclientlib.scm +++ /dev/null @@ -1,63 +0,0 @@ -(define sub (make-socket 'sub)) -(define push (make-socket 'push)) -(socket-option-set! sub 'subscribe cname) -(socket-option-set! sub 'hwm 1000) -(socket-option-set! push 'hwm 1000) - -(connect-socket sub "tcp://localhost:6563") -(connect-socket push "tcp://localhost:6564") - -(thread-sleep! 0.2) - -(define (server-ping cname timeout) - (let ((msg (conc cname ":ping:" timeout)) - (maxtime (+ (current-seconds) timeout))) - (print "pinging server from " cname " with timeout " timeout) - (let loop ((res #f)) - (if (< maxtime (current-seconds)) - #f ;; failed to ping - (if (equal? res "Got ping") - #t - (begin - (print "Ping received from server " res) - (send-message push msg) - (thread-sleep! 0.1) - (loop (receive-message sub non-blocking: #t)))))))) - -(define (dbaccess cname cmd var val #!key (numtries 20)) - (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var))) - (res #f) - (mtx1 (make-mutex)) - (do-access (lambda () - (let ((tmpres #f)) - (print "Sending msg: " msg) - (send-message push msg) - (print "Message " msg " sent") - (print "Client " cname " waiting for response to " msg) - (print "Client " cname " received address " (receive-message* sub)) - (set! tmpres (receive-message* sub)) - (mutex-lock! mtx1) - (set! res tmpres) - (mutex-unlock! mtx1)))) - (th1 (make-thread do-access "do access")) - (th2 (make-thread (lambda () - (let ((result #f)) - (mutex-lock! mtx1) - (set! result res) - (mutex-unlock! mtx1) - (thread-sleep! 5) - (if (not result) - (if (> numtries 0) - (begin - (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries) - (dbaccess cname cmd var val numtries: (- numtries 1))) - (begin - (print "ERROR: dbaccess timed out. Exiting") - (exit))))) - "timeout thread")))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1) - (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts")) - res)) - DELETED testzmq/mockupserver.scm Index: testzmq/mockupserver.scm ================================================================== --- testzmq/mockupserver.scm +++ /dev/null @@ -1,151 +0,0 @@ -;; pub/sub with envelope address -;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon -;; as a client disconnects. Also a remaining client may receive tons of -;; messages afterward. - -(use zmq srfi-18 sqlite3 numbers) - -(define pub (make-socket 'pub)) -(define pull (make-socket 'pull)) -(define cname "server") -(define total-db-accesses 0) -(define start-time (current-seconds)) - -(socket-option-set! pub 'hwm 1000) -(socket-option-set! pull 'hwm 1000) - -(bind-socket pub "tcp://*:6563") -(bind-socket pull "tcp://*:6564") - -(thread-sleep! 0.2) - -(define (open-db) - (let* ((dbpath "mockup.db") - (dbexists (file-exists? dbpath)) - (db (open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 10))) - (set-busy-handler! db handler) - (if (not dbexists) - (for-each - (lambda (stmt) - (execute db stmt)) - (list - "PRAGMA SYNCHRONOUS=0;" - "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);" - "CREATE TABLE vars (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));"))) - db)) - -(define cid-cache (make-hash-table)) - -(define (get-client-id db cname) - (let ((cid (hash-table-ref/default cid-cache cname #f))) - (if cid - cid - (begin - (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname) - (for-each-row - (lambda (id) - (set! cid id)) - db - "SELECT id FROM clients WHERE name=?;" cname) - (hash-table-set! cid-cache cname cid) - (set! total-db-accesses (+ total-db-accesses 2)) - cid)))) - -(define (count-client db cname) - (let ((cid (get-client-id db cname))) - (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid) - (set! total-db-accesses (+ total-db-accesses 1)) - )) - -(define db (open-db)) -;; (define queuelst '()) -;; (define mx1 (make-mutex)) - -(define max-queue-len 0) - -(define (process-queue queuelst) - (let ((queuelen (length queuelst))) - (if (> queuelen max-queue-len) - (set! max-queue-len queuelen)) - (for-each - (lambda (item) - (let ((cname (vector-ref item 1)) - (clcmd (vector-ref item 2)) - (cdata (vector-ref item 3))) - (send-message pub cname send-more: #t) - (send-message pub (case clcmd - ((sync) - (conc queuelen)) - ((set) - (set! total-db-accesses (+ total-db-accesses 1)) - (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata)) - "ok") - ((get) - (set! total-db-accesses (+ total-db-accesses 1)) - (let ((res "noval")) - (for-each-row - (lambda (val) - (set! res val)) - db - "SELECT val FROM vars WHERE var=?;" cdata) - res)) - (else (conc "unk cmd: " clcmd)))))) - queuelst))) - -;; SERVER THREAD -(define th1 (make-thread - (lambda () - (let ((last-run 0)) ;; current-seconds when run last - (let loop ((queuelst '())) - (let* ((indat (receive-message* pull)) - (parts (string-split indat ":")) - (cname (car parts)) ;; client name - (clcmd (string->symbol (cadr parts))) ;; client cmd - (cdata (caddr parts)) ;; client data - (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue - ;; (print "Server received message: " indat) - (count-client db cname) - (case clcmd - ((ping) - (print "Got ping from " cname) - (send-message pub cname send-more: #t) - (send-message pub "Got ping") - (loop queuelst)) - ((sync) ;; just process the queue - (print "Got sync from " cname) - (process-queue (cons svect queuelst)) - (loop '())) - ((get) - (process-queue (cons svect queuelst)) - (loop '())) - (else - (loop (cons svect queuelst)))))))) - "server thread")) - -(include "mockupclientlib.scm") - -;; SYNC THREAD -;; send a sync to the pull port -(define th2 (make-thread - (lambda () - (let ((last-action-time (current-seconds))) - (let loop () - (thread-sleep! 5) - (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f))) - (last-action-delta #f)) - (if (> queuelen 1)(set! last-action-time (current-seconds))) - (set! last-action-delta (- (current-seconds) last-action-time)) - (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta) - (if (< last-action-delta 60) - (loop) - (print "Server exiting, 25 seconds since last access")))))) - "sync thread")) - -(thread-start! th1) -(thread-start! th2) -(thread-join! th2) - -(let* ((run-time (- (current-seconds) start-time)) - (queries/second (/ total-db-accesses run-time))) - (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len)) DELETED testzmq/random.scm Index: testzmq/random.scm ================================================================== --- testzmq/random.scm +++ /dev/null @@ -1,8 +0,0 @@ -(use posix numbers) -(randomize (inexact->exact (current-seconds))) - -(define low (string->number (cadr (argv)))) -(define hi (string->number (caddr (argv)))) - -(print (+ low (random (- hi low)))) - DELETED testzmq/testmockup.sh Index: testzmq/testmockup.sh ================================================================== --- testzmq/testmockup.sh +++ /dev/null @@ -1,41 +0,0 @@ -#!/bin/bash - -rm -f mockup.db - -echo Compiling mockupserver.scm and mockupclient.scm - -# Clean up first -killall mockupserver mockupclient -v - -csc random.scm -csc mockupserver.scm -csc mockupclient.scm - -echo Starting server -./mockupserver & - -sleep 1 - -rm -f mockupclients.log - -echo Starting clients -for i in a b c d e f g h i j k l m n o p q s t u v w x y z; - do - for k in a b; - do - for j in 0 1 2 3 4 5 6 7 8 9; - do - waittime=`./random 0 60` - runtime=`./random 5 120` - echo "Starting client $i$k$j with waittime $waittime and runtime $runtime" - (sleep $waittime;./mockupclient $i$k$j $runtime) & - # >> mockupclients.log & - done - done -done - -wait -echo testmockup.sh script done -# echo "Waiting for 5 seconds then killing all mockupserver and mockupclient processes" -# sleep 30 -# killall -v mockupserver mockupclient ADDED trackback.scm Index: trackback.scm ================================================================== --- /dev/null +++ trackback.scm @@ -0,0 +1,36 @@ +(include "codescanlib.scm") + +;; show call paths for named procedure +(define (traceback-proc in-procname) + (letrec* ((all-scm-files (glob "*.scm")) + (xref (get-xref all-scm-files)) + (have (alist-ref (string->symbol in-procname) xref eq? #f)) + (lookup (lambda (path procname depth) + (let* ((upcone-temp (filter (lambda (x) + (eq? procname (car x))) + xref)) + (upcone-temp2 (cond + ((null? upcone-temp) '()) + (else (cdar upcone-temp)))) + (upcone (filter + (lambda (x) (not (eq? x procname))) + upcone-temp2)) + (uppath (cons procname path)) + (updepth (add1 depth))) + (if (null? upcone) + (print uppath) + (for-each (lambda (x) + (if (not (member procname path)) + (lookup uppath x updepth) )) + upcone)))))) + (if have + (lookup '() (string->symbol in-procname) 0) + (print "no such func - "in-procname)))) + + +(if (eq? 1 (length (command-line-arguments))) + (traceback-proc (car (command-line-arguments))) + (print "Usage: trackback ")) + +(exit 0) + Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -22,11 +22,11 @@ (declare (uses launch)) (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) (declare (uses server)) -(declare (uses synchash)) +;; (declare (uses synchash)) (declare (uses dcommon)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") @@ -69,11 +69,14 @@ (define (tree:add-node obj top nodelst #!key (userdata #f)) (let ((curr-top (iup:attribute obj "TITLE0"))) (if (or (not (string? curr-top)) (string-null? curr-top) (string-match "^\\s*$" curr-top)) - (iup:attribute-set! obj "ADDBRANCH0" top)) + (iup:attribute-set! obj "ADDBRANCH0" top)) + + + (cond ((not (equal? top (iup:attribute obj "TITLE0"))) (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else Index: utils/Makefile.git.installall ================================================================== --- utils/Makefile.git.installall +++ utils/Makefile.git.installall @@ -47,11 +47,11 @@ PROXY= # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.10.1 +CHICKEN_VERSION=4.12.0rc2 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -174,10 +174,13 @@ cd chicken-core; pwd cd chicken-core; fossil open ../chicken-scheme.fossil cd chicken-core; fossil up 337f5be # wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz +chicken-4.12.0rc2.tar.gz : + wget https://code.call-cc.org/dev-snapshots/2017/02/06/chicken-4.12.0rc2.tar.gz + # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(PRODCHICKEN)/bin/chicken : wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -45,11 +45,11 @@ # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc # CHICKEN_VERSION=4.10.0 -CHICKEN_VERSION=4.11.0rc2 +CHICKEN_VERSION=4.11.0 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -56,11 +56,11 @@ IUPCONFIG=ubuntu-15.04.inc # iup-3.15 # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ - dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + dot-locking posix-utils posix-extras hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars pathname-expand \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ crypt parley @@ -97,11 +97,11 @@ else ARCHSIZE=64_ endif CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') -CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C -fPIC" # CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) nogui : base mutils #all : nogui libiup $(PREFIX)/lib/sqlite3.so @@ -137,11 +137,12 @@ mkdir -p eggflags touch $(EGGFLAGS) # some setup stuff # -$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) +#$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) +$(PREFIX)/setup-chicken4x.sh : mkdir -p $(PREFIX) (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) $(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) @@ -149,35 +150,26 @@ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) # NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz - tar xf chicken-$(CHICKEN_VERSION).tar.gz + tar xzf chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi -chicken-4.9.0rc1.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz - -chicken-4.9.0.1.tar.gz : - wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz - -chicken-4.10.0rc1.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz - -chicken-4.10.0.tar.gz : - wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz - -chicken-4.11.0rc2.tar.gz : - wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz +chicken-4.11.0.tar.gz : + wget http://code.call-cc.org/releases/4.11.0/chicken-4.11.0.tar.gz # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh - cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) - cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + pwd; env; which make + cd chicken-core; make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core; make PLATFORM=linux PREFIX=$(PREFIX) install + #cd chicken-core;env -i PATH=${PATH} LD_LIBRARY_PATH=${LD_LIBRARY_PATH} make PLATFORM=linux PREFIX=$(PREFIX) + #cd chicken-core;env -i PATH=${PATH} LD_LIBRARY_PATH=${LD_LIBRARY_PATH} make PLATFORM=linux PREFIX=$(PREFIX) install #====================================================================== # S Q L I T E 3 #====================================================================== # https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz @@ -235,11 +227,12 @@ $(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm cd opensrc/margs;chicken-install opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so - cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + env | grep CSC + cd opensrc/histstore; $(PREFIX)/bin/csc histstore.scm -o hs $(PREFIX)/bin/hs : opensrc/histstore/hs cp -f opensrc/histstore/hs $(PREFIX)/bin/hs # stml @@ -254,11 +247,11 @@ stml/requirements.scm : stml/requirements.scm.template cp stml/install.cfg.template stml/install.cfg cp stml/requirements.scm.template stml/requirements.scm $(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm - cd stml;make + cd stml; make #====================================================================== # F F C A L L (Used by IUP) #====================================================================== @@ -280,34 +273,47 @@ iuplib.fossil : fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil cd-5.9_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download mv download cd-5.9_Linux26g4_64_lib.tar.gz +cd-5.10_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/cd-5.10_Linux26g4_64_lib.tar.gz cd-5.10_Linux26g4_64_lib.tar.gz + iup-3.17_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download - mv download iup-3.17_Linux26g4_64_lib.tar.gz + cp /p/fdk/gwa/jmoon18/iup-3.17_Linux26g4_64_lib.tar.gz iup-3.17_Linux26g4_64_lib.tar.gz +# wget --no-check-certificate -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download +# mv download iup-3.17_Linux26g4_64_lib.tar.gz + +iup-3.19.1_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/iup-3.19.1_Linux26g4_64_lib.tar.gz iup-3.19.1_Linux26g4_64_lib.tar.gz im-3.10_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download mv download im-3.10_Linux26g4_64_lib.tar.gz +im-3.11_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/im-3.11_Linux26g4_64_lib.tar.gz im-3.11_Linux26g4_64_lib.tar.gz + lua-5.3.2_Linux26g4_64_lib.tar.gz : - wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + wget --no-check-certificate -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download mv download lua-5.3.2_Linux26g4_64_lib.tar.gz +lua-5.3.3_Linux26g4_64_lib.tar.gz : + cp /p/fdk/gwa/jmoon18/lua-5.3.3_Linux26g4_64_lib.tar.gz lua-5.3.3_Linux26g4_64_lib.tar.gz + iup/installall.sh : $(PREFIX)/lib/libiup.so \ - cd-5.9_Linux26g4_64_lib.tar.gz \ + cd-5.10_Linux26g4_64_lib.tar.gz \ iup-3.17_Linux26g4_64_lib.tar.gz \ - im-3.10_Linux26g4_64_lib.tar.gz \ - lua-5.3.2_Linux26g4_64_lib.tar.gz # iuplib.fossil + im-3.11_Linux26g4_64_lib.tar.gz \ + lua-5.3.3_Linux26g4_64_lib.tar.gz # iuplib.fossil mkdir -p iup pwd - tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ - tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf cd-5.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.11_Linux26g4_64_lib.tar.gz -C iup/ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ cp iup/include/* $(PREFIX)/include/ cp iup/*.so $(PREFIX)/lib/ cp iup/*.a $(PREFIX)/lib/ @@ -331,6 +337,6 @@ $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw clean : - rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) + rm -rf chicken-4.11.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) ADDED utils/checkPreReqs Index: utils/checkPreReqs ================================================================== --- /dev/null +++ utils/checkPreReqs @@ -0,0 +1,30 @@ +#!/bin/bash +SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i) +file=`/bin/mktemp` +case $SYSTEM_TYPE in +Ubuntu-17.04-x86_64-std) + apt list --installed | cut -d/ -f 1 > $file + ;; +Ubuntu-16.04-x86_64) + apt list --installed | cut -d/ -f 1 > $file + ;; +Ubuntu-16.04-i686) + apt list --installed | cut -d/ -f 1 > $file + ;; +SUSE_LINUX_11-x86_64) + rpm -qa > $file + ;; +CentOS_5.11-x86_64-std) + rpm -qa > $file + ;; +esac + + + +for package in libmysqlclient-dev libsqlite3-dev sqlite3 postgresql libreadline-dev libwebkitgtk-dev libpangox-1.0-0 zlib1g-dev libfreetype6 cmake libssl-dev uuid-dev libmotif3 mysql-client; do + grep --silent $package $file + if [ "$?" != "0" ]; then + echo "sudo apt install $package" + fi +done +rm $file ADDED utils/cleanup-pkts.sh Index: utils/cleanup-pkts.sh ================================================================== --- /dev/null +++ utils/cleanup-pkts.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +pushd $1 + +for x in *.pkt;do + if grep 'T configf' $x > /dev/null;then + rm $x + else + echo skip $x + fi +done + ADDED utils/editwiki Index: utils/editwiki ================================================================== --- /dev/null +++ utils/editwiki @@ -0,0 +1,56 @@ +#!/bin/bash + +wikiname=$1 +FOSSILBIN=fossil + +if [ x"$wikiname" == "x" ];then + echo "Usage: viwiki wikipagename" + exit +fi + +$FOSSILBIN sync + +# wikitmpfile=`mktemp /tmp/${USER}_wikiedit.XXXXXXX` +wikitmpfile=${wikiname}.in + +if ! $FOSSILBIN wiki export "$wikiname" 2> /dev/null 1> $wikitmpfile ;then + cat /dev/null > $wikitmpfile + wikipagestate='new' +else + wikipagestate='existing' +fi + +# make a backup copy of the extracted file to diff detect if changed +cp $wikitmpfile ${wikitmpfile}.orig + +if [[ x"$EDITOR" == "x" ]];then # || [[ x"$VISUAL" == "x" ]];then + EDITOR="gvim -f" +fi + +echo $EDITOR | grep -q -e gvim +isGvim=$? + +echo $EDITOR | grep -q -e 'gvim.*-f' +hasF=$? + +if [[ $isGvim == 0 && $hasF != 0 ]]; then + EDITOR="$EDITOR -f" +fi + +$EDITOR $wikitmpfile + +if ! diff -q $wikitmpfile ${wikitmpfile}.orig;then + echo "Saving changes to $wikitmpfile to wiki" + if [ $wikipagestate == 'new' ];then + $FOSSILBIN wiki create "$wikiname" $wikitmpfile + else + $FOSSILBIN wiki commit "$wikiname" $wikitmpfile + fi +else + echo "Not saving, no changes to $wikitmpfile." +fi + +$FOSSILBIN sync + +# NOTE// We *keep* the wikitmpfile but remove the orig copy +rm -f ${wikitmpfile}.orig Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -12,20 +12,28 @@ # # This program is distributed WITHOUT ANY WARRANTY; without even the # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. -if [[ $OPTION=="" ]]; then +# echo OPTION=$OPTION + +# BKM for ubuntu 17.04: +# sudo dpkg -i libpng12-0_1.2.54-1ubuntu1_amd64.deb +# sudo dpkg -i libpng12-0_1.2.54-1ubuntu1_amd64.deb + + +if [[ $OPTION == "" ]]; then export OPTION=std fi echo You may need to do the following first: -echo sudo apt-get install libreadline-dev -echo sudo apt-get install libwebkitgtk-dev -echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake -echo sudo apt-get install libssl-dev uuid-dev -echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 +echo sudo apt install libreadline-dev +echo sudo apt install libwebkitgtk-dev +echo sudo apt install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake +echo sudo apt install libssl-dev uuid-dev +echo sudo apt install libmotif3 -OR- set KTYPE=26g4 +echo sudo apt install cmake curl ruby wget echo echo Set OPTION to std, currently OPTION=$OPTION echo echo Additionally, if you want mysql-client, you will need to make sure echo mysql_config is in your path @@ -35,48 +43,79 @@ echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION -CHICKEN_VERSION=4.11.0 -CHICKEN_BASEVER=4.11.0 + +CHICKEN_VERSION=4.10.0 +CHICKEN_BASEVER=4.10.0 # Set up variables # case $SYSTEM_TYPE in +Ubuntu-17.10-x86_64-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; +Ubuntu-17.04-x86_64-std) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; Ubuntu-16.04-x86_64-std) KTYPE=32 - CDVER=5.10 - IUPVER=3.17 - IMVER=3.11 - CHICKEN_VERSION=4.12.0 - CHICKEN_BASEVER=4.12.0 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 + ;; +Ubuntu-16.04-x86_64-new) + KTYPE=32 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 + CHICKEN_VERSION=4.13.0 + CHICKEN_BASEVER=4.13.0 ;; Ubuntu-16.04-i686-std) KTYPE=32 - CDVER=5.10 - IUPVER=3.17 - IMVER=3.11 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 +# CHICKEN_VERSION=4.12.0 +# CHICKEN_BASEVER=4.12.0 ;; SUSE_LINUX_11-x86_64-std) KTYPE=26g4 - CDVER=5.10 - IUPVER=3.17 - IMVER=3.11 + CDVER=5.11.1 + IUPVER=3.22 + IMVER=3.12 ;; CentOS_5.11-x86_64-std) KTYPE=24g3 CDVER=5.4.1 IUPVER=3.5 IMVER=3.6.3 ;; esac +echo SYSTEM_TYPE=$SYSTEM_TYPE echo KTYPE=$KTYPE echo CDVER=$CDVER echo IUPVER=$IUPVER echo IMVER=$IMVER +echo CHICKEN_VERSION=$CHICKEN_VERSION +echo CHICKEN_BASEVER=$CHICKEN_BASEVER + # NOTES: # # Centos with security setup may need to do commands such as following as root: # # NB// fix the paths first @@ -101,10 +140,11 @@ if [[ $proxy == "" ]]; then echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' echo PROX="" else export http_proxy=http://$proxy + export https_proxy=http://$proxy export PROX="-proxy $proxy" fi if [[ $KTYPE == "" ]]; then echo 'Using KTYPE=26' @@ -153,22 +193,25 @@ 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 +#if [[ ! -e 1.0.0.tar.gz ]];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 +#fi +if ! [[ -e $PREFIX/lib/libnanomsg.so ]]; 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 + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX nanomsg +fi +cd $BUILDHOME export SQLITE3_VERSION=3090200 if ! [[ -e $PREFIX/bin/sqlite3 ]]; then echo Install sqlite3 sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz @@ -182,15 +225,28 @@ tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) fi fi fi - +if ! [[ -e $PREFIX/bin/pg_config ]]; then + echo Install Postgresql + pgsql_tgz=postgresql-9.6.4.tar.gz + if ! [[ -e tgz/$pgsql_tgz ]]; then + wget -c https://ftp.postgresql.org/pub/source/v9.6.4/$pgsql_tgz + mv $pgsql_tgz tgz + fi + if ! [[ -e $PREFIX/bin/pg_config ]]; then + if [[ -e tgz/$pgsql_tgz ]]; then + tar xfz tgz/$pgsql_tgz + (cd postgresql-9.6.4; ./configure --prefix=$PREFIX --with-openssl; make; make install) + fi + fi +fi cd $BUILDHOME -for egg in "sqlite3" sql-de-lite # nanomsg +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 @@ -202,22 +258,24 @@ # 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 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 \ + tcp rpc csv-xml fmt json md5 awful http-client:0.7.1 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 \ + sxml-modifications z3 call-with-environment-variables \ + pathname-expand typed-records \ + logpro \ + 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 + udp uuid uuid-lib zlib postgresql do echo "Installing $egg" $CHICKEN_INSTALL $PROX -keep-installed $egg #$CHICKEN_INSTALL $PROX $egg @@ -225,38 +283,23 @@ echo "$egg failed to install" exit 1 fi done -if [[ -e `which mysql_config` ]]; then - $CHICKEN_INSTALL $PROX -keep-installed mysql-client +if [[ ! -e $PREFIX/lib/chicken/7/mysql-client.so ]];then + if [[ -e `which mysql_config` ]]; then + $CHICKEN_INSTALL $PROX mysql-client + fi fi 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 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_ @@ -270,21 +313,25 @@ fi echo $files mkdir -p $PREFIX/iuplib mkdir -p iup/ -for a in `echo $files` ; do +for a in $files ; do + targfile=$(echo $a | cut -d'/' -f2) if ! [[ -e tgz/$a ]] ; then 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/ + mv $targfile tgz/ + fi + if ! [[ -e tgz/$targfile ]] ; then + echo "ERROR: Failed to get http://www.kiatoa.com/matt/chicken-build/$a, please report this to matt@kiatoa.com" + exit 1 fi - echo Untarring tgz/$a into $BUILDHOME/lib - 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) + echo Untarring tgz/$targfile into $BUILDHOME/lib + tar -xzf tgz/$targfile -C iup/ done + cp iup/include/* $PREFIX/include/ cp iup/*.so $PREFIX/lib/ cp iup/*.a $PREFIX/lib/ cp iup/ftgl/lib/*/* $PREFIX/lib/ cd $BUILDHOME @@ -319,14 +366,16 @@ $PREFIX/bin/chicken-install cd ../dbi $PREFIX/bin/chicken-install cd ../margs $PREFIX/bin/chicken-install + cd ../pkts + $PREFIX/bin/chicken-install fi cd $BUILDHOME -if ! [[ -e $PREFIX/bin/stmlrun ]] ; then +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 @@ -346,22 +395,26 @@ 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$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot $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$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 cd $BUILDHOME # install ducttape -cd ../ducttape -$CHICKEN_INSTALL +if [[ -e ../ducttape ]];then + cd ../ducttape + $CHICKEN_INSTALL +else + echo "ducttape egg not found at ../ducttape. You will need to cd into the ducttape directory in the megatest distribution and run \"chicken-install\"" +fi cd $BUILDHOME 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 ADDED utils/memproblem.scm Index: utils/memproblem.scm ================================================================== --- /dev/null +++ utils/memproblem.scm @@ -0,0 +1,48 @@ +;; Run like this: ((adjust the "30" number to a value that fills memory on the machine you are using) +;; script -c "free -g ; utils/memproblem 30 -:hm128G" memclean.log + +;; Fill the cache with something like this: +;; find /path/to/lots/of/files/ -type f -exec cat {} > /dev/null \; + + +(use posix numbers srfi-4) + +(define num-iter (or (if (> (length (argv)) 2) + (string->number (cadr (argv))) + #f) + 43)) ;; Gigs memory to try to allocate +;; (print "Allocating up to " memsize "G memory. Note that due to the usage of the heap this will actually use up to " (* 2 memsize) "G") + +(define (get-free) + (let ((indat (with-input-from-pipe + "free" + read-lines))) + (map string->number + (cdr + (string-split + (cadr indat)))))) + +(define-inline (cached dat)(list-ref dat 5)) +(define-inline (used dat)(list-ref dat 1)) +(define-inline (free dat)(list-ref dat 2)) + +(define-inline (k->G val)(/ val 1e6)) +(define-inline (G->k val)(* val 1e6)) + +(define start-time (current-milliseconds)) + +(let loop ((n 0) + (dat (get-free)) + (stuff '())) + (let ((bigvec (make-u32vector 200000000)) + (startt (current-milliseconds))) + (print "Value at 100: " (u32vector-ref bigvec 100) " ms to access: " (- (current-milliseconds) startt)) + (u32vector-set! bigvec (random 190000000) 111) + (print n " Elapsed time: " (/ (- (current-milliseconds) start-time) 1000) " s " + "Cached: " (k->G (cached dat)) " G " + "Used: " (k->G (used dat)) " G ") + (if (< n num-iter) + (loop (+ n 1)(get-free) (cons bigvec stuff))))) + +(exit) + Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -1,13 +1,13 @@ #!/bin/bash prefix=$1 cmd=$2 target=$3 +cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" if [ "$LD_LIBRARY_PATH" != "" ];then - cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 ( cat << __EOF if [ "\$LD_LIBRARY_PATH" != "" ];then export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH else @@ -18,15 +18,10 @@ echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi -# echo "#!/bin/bash" > $target -# if [ "$LD_LIBRARY_PATH" != "" ];then -# echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target -# fi -# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "#!/bin/bash" > $target if [[ $cmd =~ dboard ]]; then cat >> $target <<'EOF' @@ -57,8 +52,19 @@ fi EOF fi +cat >> $target << EOF +if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 10000 ]];then ulimit -n 10000;fi +EOF + +# echo "#!/bin/bash" > $target +# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target + echo "lsbr=\$(lsb_release -sr)" >> $target -echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target +if [ "$LD_LIBRARY_PATH" != "" ];then + echo "source $prefix/bin/.\$lsbr/cfg.sh" >> $target +fi + +# echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target ADDED utils/mtrept.sh Index: utils/mtrept.sh ================================================================== --- /dev/null +++ utils/mtrept.sh @@ -0,0 +1,58 @@ +#!/bin/bash +# +# Rollup counts of calls to Megatest from a logging dat file +# +# Usage: mtrept.sh file [host] + +if [[ "$2"x != "x" ]];then + host_name_grep="grep $2 | " +else + host_name_grep="" +fi +if [[ "$1"x == "x" ]];then + datfile=/p/fdk/gwa/$USER/.logger/all.dat +else + datfile=$1 +fi +datcopy=/tmp/$USER/all.$PID.dat + +if [[ -e $datfile ]];then + cp $datfile $datcopy + list_runs=$(grep list-runs $datcopy |$host_name_grep wc -l) + show_config=$(grep show-config $datcopy |$host_name_grep wc -l) + list_targets=$(grep list-targets $datcopy |$host_name_grep wc -l) + mt_run=$(grep ' -run ' $datcopy |$host_name_grep wc -l) + execute=$(grep ' -execute' $datcopy|$host_name_grep wc -l) + server=$(grep ' -server' $datcopy|$host_name_grep wc -l) + sync_to=$(grep ' -sync-to' $datcopy|$host_name_grep wc -l) + step=$(grep ' -step' $datcopy|$host_name_grep wc -l) + state_status=$(grep ' -set-state-status' $datcopy|$host_name_grep wc -l) + test_status=$(grep ' -test-status' $datcopy|$host_name_grep wc -l) + other=$(egrep -v ' -(list-runs|show-config|list-targets|run|execute|server|sync-to|step|set-state-status|test-status)' $datcopy |$host_name_grep wc -l) + start_time=$(head -1 $datcopy|awk '{print $1}') + end_time=$(tail -1 $datcopy | awk '{print $1}') + minutes=$(echo "($end_time-$start_time)/60.0" | bc) + hours=$(echo "($minutes/60)"|bc) + total_calls=$(cat $datcopy |$host_name_grep wc -l) + + if [[ $hours -gt 2 ]];then + echo "Over $hours hour period we have;" + else + echo "Over $minutes minutes we have;" + fi + echo " list-runs: $list_runs" + echo " show-config: $show_config" + echo " list-targets: $list_targets" + echo " execute: $execute" + echo " run: $mt_run" + echo " server: $server" + echo " step: $step" + echo " test-status: $test_status" + echo " sync-to: $sync_to" + echo " state-status: $state_status" + echo " other: $other" + echo " total: $total_calls" +else + echo "Could not find input file $datfile" +fi + ADDED utils/run2mock.scm Index: utils/run2mock.scm ================================================================== --- /dev/null +++ utils/run2mock.scm @@ -0,0 +1,169 @@ +#!/p/foundry/env/pkgs/chicken/4.10.1_v1.63/bin/csi -s +; -*- Mode: Scheme; -*- + + +(use ducttape-lib) +(use posix-extras pathname-expand regex matchable) +(use ini-file) +;; plugs a hole in posix-extras in latter chicken versions +(define ##sys#expand-home-path pathname-expand) +(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + +;; resolve fullpath to this script +(define (get-this-script-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) + +(define *this-script-fullpath* (get-this-script-fullpath)) +(define *this-script-dir* (pathname-directory *this-script-fullpath*)) +(define *this-script-name* (pathname-strip-directory *this-script-fullpath*)) + +(define (false-on-exception thunk) + (handle-exceptions exn #f (thunk) )) + +(define (safe-file-exists? path-string) + (false-on-exception (lambda () (file-exists? path-string)))) + + +(define (crude-config-transformer infile outfile keep-sections-list append-text #!key (filter-patt #f)) + (let* ((inlines (with-input-from-file infile read-lines)) + (keep-lines (let loop ((lines-left inlines) (lines-out '()) (current-section #f) (section-lines-accumulator '())) + (let* ((this-line (if (not (null? lines-left)) + (car lines-left) + "")) + (section-match (string-match "^\\s*\\[([^\\]]+)\\].*" this-line))) + (cond + ((null? lines-left) + (if (member current-section keep-sections-list) + (append lines-out (reverse section-lines-accumulator)) + lines-out)) + (section-match + (let* ((next-lines-left (cdr lines-left)) + (next-lines-out (if (member current-section keep-sections-list) + (append lines-out (reverse section-lines-accumulator)) + lines-out)) + (next-current-section (cadr section-match)) + (next-section-lines-accumulator (list this-line))) + (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator))) + (else + (let* ((next-lines-left (cdr lines-left)) + (next-lines-out lines-out) + (next-current-section current-section) + (next-section-lines-accumulator + (cond + ((and filter-patt (string-match (conc "^.*"filter-patt".*$") this-line)) + section-lines-accumulator) + (else (cons this-line section-lines-accumulator))))) + (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator)))))))) + (with-output-to-file outfile (lambda () + (print (string-join keep-lines "\n")) + (print) + (print append-text) + (print))))) + + +(define (testconfig-transformer infile outfile) + (crude-config-transformer + infile + outfile + '("meta" "items" "requirements" "test_meta") + + (conc " + +[ezsteps] +alwayspass /bin/true + +"))) + + + + + +(let* ((mtexe "/p/foundry/env/pkgs/megatest/1.64/31/bin/megatest") + (faux-mtra "/p/fdk/gwa/bjbarcla/issues/mtdev/ch/cap/faux") + (src-mtra "/nfs/pdx/disks/icf_fdk_asic_gwa002/asicfdkqa/fossil/megatestqa/afdkqa") + (target "p1275/5/ADF_r0.7_s/9p27t_tp0") + (run "ww38.4") + (src-mtdb (conc src-mtra "/megatest.db")) + (extra-src-testdirs '("/p/fdk/gwa/asicfdkqa/fossil/ext/afdkqa_ext/trunk/tests")) + (mtconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-config -target "target) read)) + (runconf (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-runconfig -dumpmode sexp -target "target) read)) + (testdir-alist (alist-ref "tests-paths" mtconf equal?)) + (testdirs (filter safe-file-exists? + (append extra-src-testdirs + (list (conc src-mtra "/tests")) + (if (and testdir-alist (not (null? testdir-alist))) + (map cadr testdir-alist) + '())))) + (tconfigfiles + (apply append (map (lambda (src-testdir) + (with-input-from-pipe (conc "ls -1 "src-testdir"/*/testconfig") read-lines)) + testdirs))) + (tconf-alist (filter identity + (map (lambda (tcfile) + (let* ((m (string-match "^.*/([^/]+)/testconfig$" tcfile))) + (if (not (null? m)) + (cons (cadr m) tcfile) + #f))) + tconfigfiles)))) + +; (pp mtconf) +; (pp (list 'FOO testdir-alist)) (exit 1) + ;; make megatest area + (when (not (file-exists? src-mtdb)) + (ierr "Source does not exist. Aborting. [src-mtdb]") + (exit 1)) + + (when (file-exists? faux-mtra) + (system (conc "cd "faux-mtra" && rm -rf $(/p/foundry/env/bin/mttmpdir)")) + (system (conc "rm -rf "faux-mtra))) + + (system (conc "mkdir -p "faux-mtra)) + (system (conc "mkdir -p "faux-mtra"/links")) + (system (conc "mkdir -p "faux-mtra"/disk0")) + + (system (conc "cd "src-mtra" && "mtexe" -show-config -target "target" -dumpmode ini > "faux-mtra"/megatest.config.in")) + (crude-config-transformer + (conc faux-mtra"/megatest.config.in") + (conc faux-mtra"/megatest.config") + '("fields" "server" "env-override" "dashboard" "validvalues") + (conc "[setup] +linktree "faux-mtra"/links +max_concurrent_jobs 1000 +launch-delay 5 +use-wal 1 + +" ;; emacs has trouble if a string has [ at the beginning of line, so breaking it up. +"[disks] +disk0 "faux-mtra"/disk0") + filter-patt: "MT_LINKTREE" + ) + + + (system (conc "cd "src-mtra" && "mtexe" -show-runconfig -target "target" -dumpmode ini > "faux-mtra"/runconfigs.config")) + + + (system (conc "mkdir -p "faux-mtra"/tests")) + + (for-each (lambda (tpair) + (pp tpair) + (let* ((testname (car tpair)) + (src-tconfigfile (cdr tpair)) + (destdir (conc faux-mtra"/tests/"testname))) + (do-or-die (conc "mkdir -p "destdir)) + (do-or-die (conc "cp "src-tconfigfile" "destdir"/testconfig.in")) + (testconfig-transformer + (conc destdir"/testconfig.in") + (conc destdir"/testconfig")) + (print "processed test "testname))) + tconf-alist) + + + ) ADDED utils/watch-close-wait.sh Index: utils/watch-close-wait.sh ================================================================== --- /dev/null +++ utils/watch-close-wait.sh @@ -0,0 +1,8 @@ +psline=$(ps -F -u $USER | grep "mtest" |grep " -run " | egrep " -(target|reqtarg) "| head -1) +id=$(echo $psline|awk '{print $2}') +echo "Watching process for command line: $psline" +echo " with PID=$id" +while true;do + echo "CLOSE_WAIT: $(lsof -n | grep CLOSE_WAIT | grep $id | wc -l) ALL OPEN: $(lsof -n |grep $id|wc -l) ALL CLOSE_WAIT: $(netstat -ap 2> /dev/null| grep -i close_wait| wc -l)" + sleep 1 +done ADDED utils/whodunit.scm Index: utils/whodunit.scm ================================================================== --- /dev/null +++ utils/whodunit.scm @@ -0,0 +1,48 @@ +(use posix srfi-69) + +(define *numsamples* (or (and (> (length (argv)) 1) + (string->number (cadr (argv)))) + 3)) + +(define (topdata) + (with-input-from-pipe + (conc "top -b -n " *numsamples* " -d 0.1") + read-lines)) + +(define (cleanup-data topdat)list + (let loop ((hed (car topdat)) + (tal (cdr topdat)) + (res '())) + (let* ((line-list (string-split hed)) + (nums (map (lambda (indat)(or (string->number indat) indat)) line-list)) + (not-data (or (null? nums) + (not (number? (car nums))))) + (new-res (if not-data res (cons nums res)))) + (if (null? tal) + new-res + (loop (car tal)(cdr tal) new-res))))) + +(print "Getting " *numsamples* " samples of cpu usage data.") +(define data (cleanup-data (topdata))) +(define pidhash (make-hash-table)) +(define userhash (make-hash-table)) + +;; sum up and normalize the +(for-each + (lambda (indat) + (let ((pid (car indat)) + (usr (cadr indat)) + (cpu (list-ref indat 8))) + (hash-table-set! userhash usr (+ cpu (hash-table-ref/default userhash usr 0))))) + data) + +(for-each + (lambda (usr) + (print usr + (if (< (string-length usr) 8) "\t\t" "\t") + (inexact->exact (round (/ (hash-table-ref userhash usr) *numsamples*))))) + (sort (hash-table-keys userhash) + (lambda (a b) + (> (hash-table-ref userhash a) + (hash-table-ref userhash b))))) + ADDED wrappers/cfg.sh Index: wrappers/cfg.sh ================================================================== --- /dev/null +++ wrappers/cfg.sh @@ -0,0 +1,6 @@ +if [ "$LD_LIBRARY_PATH" != "" ];then + export LD_LIBRARY_PATH=PREFIX:PREFIX/lib:PREFIX/lib64:$LD_LIBRARY_PATH +else + export LD_LIBRARY_PATH=PREFIX:PREFIX/lib:PREFIX/lib64 +fi + ADDED wrappers/dashboard Index: wrappers/dashboard ================================================================== --- /dev/null +++ wrappers/dashboard @@ -0,0 +1,32 @@ +#!/bin/bash + +# # disable if not running on homehost +# if [[ -e .homehost ]]; then +# homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' ) +# hostname=$( hostname -f ) +# +# if [[ ! ($homehostname == $hostname) ]]; then +# echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area. Cannot start dashboard." +# echo " Please log into homehost before launching dashboard." +# exit 1 +# fi +# fi + +# check that $DISPLAY is set +if [[ -z $DISPLAY ]]; then + echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' + exit 1 +fi + +# check that $DISPLAY is proper +if [[ -x $(which xdpyinfo 2>/dev/null) ]]; then + if ! xdpyinfo -display "$DISPLAY" &>/dev/null; then + echo 'ERROR: megatest dashboard cannot open display "'$DISPLAY'". Please check $DISPLAY environment variable.' + exit 1 + fi +fi +if [[ $(ulimit -a | grep 'open files' | awk '{print $4}') -gt 10000 ]];then ulimit -n 10000;fi +lsbr=$(lsb_release -sr) +source PREFIX/ARCHSTR/cfg.sh +exec PREFIX/dboard "$@" + ADDED wrappers/megatest Index: wrappers/megatest ================================================================== --- /dev/null +++ wrappers/megatest @@ -0,0 +1,6 @@ +#!/bin/bash +if [[ $(ulimit -a | grep 'open files' | awk '{print $4}') -gt 10000 ]];then ulimit -n 10000;fi +lsbr=$(lsb_release -sr) +source PREFIX/ARCHSTR/cfg.sh +exec PREFIX/mtest "$@" +