ADDED Makefile.deploy Index: Makefile.deploy ================================================================== --- /dev/null +++ Makefile.deploy @@ -0,0 +1,341 @@ +# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' +PREFIX=$(PWD) +CSCOPTS= -deploy +INSTALL=install +SRCFILES = common.scm items.scm launch.scm \ + ods.scm runconfig.scm server.scm configf.scm \ + db.scm keys.scm margs.scm megatest-version.scm \ + process.scm runs.scm tasks.scm tests.scm genexample.scm \ + http-transport.scm filedb.scm \ + client.scm synchash.scm daemon.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm tdb.scm rpc-transport.scm \ + portlogger.scm archive.scm env.scm + +# Eggs to install (straightforward ones) +EGGS=crypt matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ +dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ +json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ +spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 + +GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm + +OFILES = $(SRCFILES:%.scm=%.o) +GOFILES = $(GUISRCF:%.scm=%.o) + +ADTLSCR=mt_laststep mt_runstep mt_ezstep +HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) +DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) +MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') + +CSIPATH=$(shell which csi) +CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) +# ARCHSTR=$(shell uname -m)_$(shell uname -r) +# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") +# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) +ARCHSTR=$(shell lsb_release -sr) +# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") + +PNGFILES = $(shell cd docs/manual;ls *png) + +ARCHSIZE=64_ +IMVER=3.11 +IUPVER=3.17 +KTYPE=26g4 +CDVER=5.10 + +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard eggs sqlite matt iup + +mtest: $(OFILES) readline-fix.scm megatest.o + mkdir -p $(PREFIX)/deploy + csc $(CSCOPTS) $(OFILES) megatest.o -o $(PREFIX)/deploy/mtest + +eggs: $(PREFIX)/deploy/mtest/fmt.so + +$(PREFIX)/deploy/mtest/fmt.so: + chicken-install -deploy -p $(PREFIX)/deploy/mtest base64 format regex-case simple-exceptions typed-records apropos directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables csv typed-records pathname-expand json crypt dot-locking csv-xml z3 sql-de-lite hostinfo rpc directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables rpc fmt + +sqlite: $(PREFIX)/deploy/mtest/sqlite3.so + +$(PREFIX)/deploy/mtest/sqlite3.so: + wget http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz + tar xfz sqlite-autoconf-3090200.tar.gz + cd sqlite-autoconf-3090200 + cd sqlite-autoconf-3090200 && ./configure --prefix=`realpath $(PREFIX)/deploy/mtest` + cd sqlite-autoconf-3090200 && make + cd sqlite-autoconf-3090200 && make install + CSC_OPTIONS='-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/' chicken-install -deploy -p $(PREFIX)/deploy/mtest sqlite3 + +matt: $(PREFIX)/deploy/mtest/stml.so + +$(PREFIX)/deploy/mtest/stml.so: + wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' + tar -xzf stml.tar.gz + cd stml && cp install.cfg.template install.cfg + cd stml && echo "TARGDIR=`realpath $(PREFIX)/deploy/mtest`" > install.cfg + cd stml && echo "LOGDIR=/tmp/stmlrun" >> install.cfg + cd stml && echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg + cd stml && cp requirements.scm.template requirements.scm + cd stml && make clean + -cd stml && CSCOPTS="-C -fPIC" make + cd stml && chicken-install -deploy -p $(PREFIX)/deploy/mtest + wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' + tar -xzf opensrc.tar.gz + cd opensrc/mutils && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/dbi && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/margs && chicken-install -deploy -p $(PREFIX)/deploy/mtest + +iup: $(PREFIX)/deploy/mtest/iup.so + +$(PREFIX)/deploy/mtest/iup.so: + wget -c http://www.kiatoa.com/matt/chicken-build/cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + tar -xzvf cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + cp $(PREFIX)/deploy/mtest/ftgl/lib/*/* $(PREFIX)/deploy/mtest/ + wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + tar -xzf ffcall.tar.gz + cd ffcall && ./configure --prefix=`realpath $(PREFIX)/deploy/mtest/` --enable-shared + cd ffcall && make CC="gcc -fPIC" + cd ffcall && make install + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks -feature disable-iup-web iup + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks canvas-draw + +dboard: $(OFILES) $(GOFILES) dashboard.scm + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o $(PREFIX)/deploy/mtest/dboard2 + cp $(PREFIX)/deploy/mtest/dboard2/dboard2 $(PREFIX)/deploy/mtest/dboard + +ndboard : newdashboard.scm $(OFILES) $(GOFILES) + csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o $(PREFIX)/deploy/mtest/newdboard + +# install documentation to $(PREFIX)/docs +# DOES NOT REBUILD DOCS +# +$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html + mkdir -p $(PREFIX)/share/docs + $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html + for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done + +#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) +# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard + +# +# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm +# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl + +# Special dependencies for the includes +tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \ +archive.o megatest.o : db_records.scm +tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm +db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +tests.o tasks.o dashboard-tasks.o : task_records.scm +runs.o : test_records.scm +megatest.o : megatest-fossil-hash.scm +client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm +common_records.scm : altdb.scm +vg.o dashboard.o : vg_records.scm +dcommon.o : run_records.scm +# Temporary while transitioning to new routine +# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm + +megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm + echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new + if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi + +$(OFILES) $(GOFILES) : common_records.scm + +%.o : %.scm + csc $(CSCOPTS) -c $< + +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper + @echo Installing to PREFIX=$(PREFIX) + $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest + utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest + chmod a+x $(PREFIX)/bin/megatest + +$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard + $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper + utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard + chmod a+x $(PREFIX)/bin/newdashboard + +#$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard +# $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard + +# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper +# utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard +# chmod a+x $(PREFIX)/bin/mdboard + +# $(HELPERS) : utils/% +# $(INSTALL) $< $@ +# chmod a+x $@ + +$(PREFIX)/bin/mt_laststep : utils/mt_laststep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_runstep : utils/mt_runstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_ezstep : utils/mt_ezstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_xterm : utils/mt_xterm + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/loadrunner : utils/loadrunner + $(INSTALL) $< $@ + chmod a+x $@ + +# $(PREFIX)/bin/refdb : refdb +# $(INSTALL) $< $@ +# chmod a+x $@ + +deploytarg/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +# install dashboard as dboard so wrapper script can be called dashboard +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper + utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard + chmod a+x $(PREFIX)/bin/dashboard + $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard + +install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ + $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html + +$(PREFIX)/bin/.$(ARCHSTR) : + mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + +test: tests/tests.scm + cd tests;csi -I .. -b -n tests.scm + +ext-tests/.fslckout : $(MTQA_FOSSIL) + mkdir -p ext-tests + cd ext-tests;fossil open --nested $(MTQA_FOSSIL) + +$(MTQA_FOSSIL) : + fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) + +clean : + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm + +#====================================================================== +# Make the records files +#====================================================================== + +# vg_records.scm : records.sh +# ./records.sh + +#====================================================================== +# Deploy section (not complete yet) +#====================================================================== + +$(DEPLOYHELPERS) : utils/mt_* + $(INSTALL) $< $@ + chmod a+X $@ + +deploytarg/apropos.so : Makefile + chicken-install -p deploytarg -deploy -keep-installed $(EGGS) + +# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ +# chicken-install -prefix deploytarg -deploy $$i;done + +# deploytarg/libsqlite3.so : +# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 + +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so + +# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so +# for i in iup im cd av call sqlite; do \ +# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ +# done +# cp $(CKPATH)/include/*.h deploytarg + +# puts deployed megatest in directory "megatest" +deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so + csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/mtest + +deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so + csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/dboard + +# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ +# megatest-version.o tdb.o ods.o mt.o keys.o +datashare-testing/sd : datashare.scm $(OFILES) + csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd + +datashare-testing/sdat: sharedat.scm $(OFILES) + csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat + +sd : datashare-testing/sd + mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath + +xterm : sd + (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) + +datashare-testing/spublish : spublish.scm $(OFILES) + csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish + +datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o + csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +sretrieve/sretrieve : datashare-testing/sretrieve + csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o + chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ + srfi-1 posix regex regex-case srfi-69 + +# base64 dot-locking \ +# csv-xml z3 + +# "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + +readline-fix.scm : + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ + else \ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ + fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi + if csi -ne '(use postgresql)';then \ + echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ + fi + +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -12,14 +12,14 @@ ;; C L I E N T S ;;====================================================================== (require-extension (srfi 18) extras tcp s11n) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) ;; (use zmq) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) @@ -111,11 +111,14 @@ (server:try-running run-id) (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) )))) - +;; ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) +;; ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects)) +;; (else (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) +;; ;; (define (client:login-no-auto-setup server-info run-id) ;; (case (server:get-transport) ;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) ;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) ;; (else (rpc:login-no-auto-client-setup server-info run-id)))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo typed-records) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -42,10 +42,32 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES + +(define *contexts* (make-hash-table)) + +;; Common data structure for +(defstruct cxt + (taskdb #f) + (cmutex (make-mutex))) + +;; safe method for accessing a context given a toppath +;; +(define (common:with-cxt toppath proc) + (mutex-lock! *context-mutex*) + (let ((cxt (hash-table-ref/default *contexts* toppath #f))) + (if (not cxt) + (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) + (let ((cxt-mutex (cxt-mutex cxt))) + (mutex-unlock! *context-mutex*) + (mutex-lock! cxt-mutex) + (let ((res (proc cxt))) + (mutex-unlock! cxt-mutex) + res)))) + (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data @@ -117,10 +139,14 @@ ;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than ;; five seconds ago (define *pre-reqs-met-cache* (make-hash-table)) +;; cache of verbosity given string +;; +(define *verbosity-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -133,10 +159,12 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) + +(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. ;;====================================================================== ;; V E R S I O N ;;====================================================================== @@ -373,10 +401,11 @@ ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) (or (args:get-arg "-runtests") + (args:get-arg "-run") (args:get-arg "-server") ;; (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") ;; (args:get-arg "-get-run-status") )) @@ -1183,10 +1212,18 @@ ;; ((RUNNING) "9 131 232") ;; ((KILLREQ) "39 82 206") ;; ((KILLED) "234 101 17") ;; ((NOT_STARTED) "240 240 240") ;; (else "192 192 192"))) + +(define (common:iup-color->rgb-hex instr) + (string-intersperse + (map (lambda (x) + (number->string x 16)) + (map string->number + (string-split instr))) + "/")) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -44,23 +44,30 @@ (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; (define (debug:calc-verbosity vstr) - (cond - ((number? vstr) vstr) - ((not (string? vstr)) 1) - ;; ((string-match "^\\s*$" vstr) 1) - (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) - (cond - ((> (length debugvals) 1) debugvals) - ((> (length debugvals) 0)(car debugvals)) - (else 1)))) - ((args:get-arg "-v") 2) - ((args:get-arg "-q") 0) - (else 1))) + (or (hash-table-ref/default *verbosity-cache* vstr #f) + (let ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1)))) + (hash-table-set! *verbosity-cache* vstr res) + res))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) @@ -119,11 +126,11 @@ stack) (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args))) (apply debug:print dp-args)))) (define (BB> . in-args) - (apply print "BB> " in-args) + ;; (apply print "BB> " in-args) "shouldn't do anything") (define (debug:print-error n e . params) ;; normal print Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -628,15 +628,13 @@ " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) - (common:without-vars - (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)) - "MT_.*")))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -86,10 +86,15 @@ "-use-local" "-skip-version-check" ) args:arg-hash 0)) + +(if (not (null? remargs)) + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit))) (if (args:get-arg "-h") (begin (print help) (exit))) @@ -256,10 +261,11 @@ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targests added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) @@ -1173,10 +1179,11 @@ ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) (db-target-dat (rmt:get-targets)) + (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") (make-list (length header) "na")) @@ -1188,11 +1195,16 @@ (map munge-target runconf-targs) ))) (for-each (lambda (target) - (tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name)) + (if (not (hash-table-ref/default runs-tree-ht target #f)) + ;; (let ((existing (tree:find-node tb target))) + ;; (if (not existing) + (begin + (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name)) + (hash-table-set! runs-tree-ht target #t)))) all-targets))) ;; Run controls panel ;; (define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) @@ -1267,10 +1279,11 @@ (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" + #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) @@ -1511,24 +1524,25 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) + ;; (let ((existing (tree:find-node tb run-path))) + ;; (if (not existing) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)))) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) (reverse (sort @@ -2729,18 +2743,18 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) + ;; (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) (begin (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids)) ;; (print "Updating rundat") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -215,11 +215,16 @@ (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) (db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists)(initproc db)) + (if (not file-exists) + (begin + (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (print "Creating " fname " in NON-WAL mode.")) + (initproc db))) ;; (release-dot-lock fname) db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (sqlite3:open-database fname))))) ;; ) @@ -315,15 +320,25 @@ (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically dbdat))))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) +;; open the local db for direct access (no server) +;; +(define (db:open-local-db-handle) + (or *dbstruct-db* + (let ((dbstruct (db:setup #f local: #t))) + (set! *dbstruct-db* dbstruct) + dbstruct))) + ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db) (let* ((dbpath (conc *toppath* "/megatest.db")) (dbexists (file-exists? dbpath)) @@ -1389,10 +1404,15 @@ (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))) + +;; given a launch delay (minimum time from last launch) return amount of time to wait +;; +;; (define (db:launch-delay-left dbstruct run-id launch-delay) + ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -550,11 +550,11 @@ (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) - (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + (list "MT_TESTSUITE_NAME" (common:get-testsuite-name)))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -708,11 +708,16 @@ (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir)))) + (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))) + (cxt (hash-table-ref/default *contexts* toppath #f))) + + ;; create our cxt for this area if it doesn't already exist + (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) + ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource (cond ;; data was read and cached and available in *configstatus*, toppath has already been set ((eq? *configstatus* 'fulldata) @@ -821,11 +826,13 @@ (begin (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") ))) (if (and *toppath* (directory-exists? *toppath*)) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area."))) (server:set-transport) *toppath*)) @@ -1031,10 +1038,18 @@ ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (let loop ((delta (- (current-seconds) *last-launch*)) + (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5")))) + (if (> launch-delay delta) + (begin + (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds") + (thread-sleep! (- launch-delay delta)) + (loop (- (current-seconds) *last-launch*) launch-delay)))) + (set! *last-launch* (current-seconds)) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6205) +(define megatest-version 1.6208) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -11,11 +11,11 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) @@ -393,11 +393,10 @@ (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) - (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log")) (set! *default-log-port* oup))) @@ -1001,11 +1000,11 @@ "-set-run-status" "set run status" (lambda (target runname keys keyvals) (let* ((runsdat (rmt:get-runs-by-patt keys runname (common:args-get-target) - #f #f #f)) + #f #f #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin (debug:print-info 0 *default-log-port* "No matching run found.") ADDED remotediff-nmsg.scm Index: remotediff-nmsg.scm ================================================================== --- /dev/null +++ remotediff-nmsg.scm @@ -0,0 +1,182 @@ +(use posix) +(use regex) +(use directory-utils) +(use srfi-18 srfi-69 nanomsg) + +(define (client-send-receive soc msg) + (nn-send soc msg) + (nn-recv soc)) + +;;do as calling user +(define (do-as-calling-user proc) + (let ((eid (current-effective-user-id)) + (cid (current-user-id))) + (if (not (eq? eid cid)) ;; running suid + (set! (current-effective-user-id) cid)) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + +;; use mutex to not open/close files at same time +;; +(define (checksum mtx file #!key (cmd "shasum")) + (mutex-lock! mtx) + (let-values (((inp oup pid) + (process cmd (list file)))) + (mutex-unlock! mtx) + (let ((result (read-line inp))) + ;; now flush out remaining output + (let loop ((inl (read-line inp))) + (if (eof-object? inl) + (if (string? result) + (begin + (mutex-lock! mtx) + (close-input-port inp) + (close-output-port oup) + (mutex-unlock! mtx) + (car (string-split result))) + #f) + (loop (read-line inp))))))) + +(define *max-running* 40) + +(define (gather-dir-info path) + (let ((mtx1 (make-mutex)) + (threads (make-hash-table)) + (last-num 0) + (req (nn-socket 'req))) + (print "starting client with pid " (current-process-id)) + (nn-connect req + ;; "tcp://localhost:5559") + "ipc:///tmp/test-ipc") + (find-files + path + ;; test: #t + action: (lambda (p res) + (let ((info (cond + ((not (file-read-access? p)) '(cant-read)) + ((directory? p) '(dir)) + ((symbolic-link? p) (list 'symlink (read-symbolic-link p))) + (else '(data))))) + (if (eq? (car info) 'data) + (let loop ((start-time (current-seconds))) + (mutex-lock! mtx1) + (let* ((num-threads (hash-table-size threads)) + (ok-to-run (> *max-running* num-threads))) + ;; (if (> (abs (- num-threads last-num)) 2) + ;; (begin + ;; ;; (print "num-threads:" num-threads) + ;; (set! last-num num-threads))) + (mutex-unlock! mtx1) + (if ok-to-run + (let ((run-time-start (current-seconds))) + ;; (print "num threads: " num-threads) + (let ((th1 (make-thread + (lambda () + (let ((cksum (checksum mtx1 p cmd: "md5sum")) + (run-time (- (current-seconds) run-time-start))) + (mutex-lock! mtx1) + (client-send-receive req (conc p " " cksum)) + (mutex-unlock! mtx1)) + (let loop2 () + (mutex-lock! mtx1) + (let ((registered (hash-table-exists? threads p))) + (if registered + (begin + ;; (print "deleting thread reference for " p) + (hash-table-delete! threads p))) ;; delete myself + (mutex-unlock! mtx1) + (if (not registered) + (begin + (thread-sleep! 0.5) + (loop2)))))) + p))) + (thread-start! th1) + ;; (thread-sleep! 0.05) ;; give things a little time to get going + ;; (thread-join! th1) ;; + (mutex-lock! mtx1) + (hash-table-set! threads p th1) + (mutex-unlock! mtx1) + )) ;; thread is launched + (let ((run-time (- (current-seconds) start-time))) ;; couldn't launch yet + (cond + ((< run-time 5)) ;; blast on through + ((< run-time 30)(thread-sleep! 0.1)) + ((< run-time 60)(thread-sleep! 2)) + ((< run-time 120)(thread-sleep! 3)) + (else (thread-sleep! 3))) + (loop start-time))))))))) + (map thread-join! (hash-table-values threads)) + (client-send-receive req "quit") + (nn-close req) + (exit))) + +;; recieve and store the file data, note: this is effectively a *server*, not a client. +;; +(define (compare-directories path1 path2) + (let ((p1dat (make-hash-table)) + (p2dat (make-hash-table)) + (numdone 0) ;; increment when recieved a quit. exit when > 2 + (rep (nn-socket 'rep)) + (p1len (string-length path1)) + (p2len (string-length path2)) + (both-seen (make-hash-table))) + (nn-bind rep + ;; "tcp://*:5559") + "ipc:///tmp/test-ipc") + ;; start clients + (thread-sleep! 0.1) + (system (conc "./remotediff-nmsg " path1 " &")) + (system (conc "./remotediff-nmsg " path2 " &")) + (let loop ((msg-in (nn-recv rep)) + (last-print 0)) + (if (equal? msg-in "quit") + (set! numdone (+ numdone 1))) + (if (and (not (equal? msg-in "quit")) + (< numdone 2)) + (let* ((parts (string-split msg-in)) + (filen (car parts)) + (finfo (cadr parts)) + (isp1 (substring-index path1 filen 0)) ;; is this a path1? + (isp2 (substring-index path2 filen 0)) ;; is this a path2? + (tpth (substring filen (if isp1 p1len p2len) (string-length filen)))) + (hash-table-set! (if isp1 p1dat p2dat) + tpth + finfo) + (if (and (hash-table-exists? p1dat tpth) + (hash-table-exists? p2dat tpth)) + (begin + (if (not (equal? (hash-table-ref p1dat tpth) + (hash-table-ref p2dat tpth))) + (print "DIFF: " tpth)) + (hash-table-set! both-seen tpth finfo))) + (nn-send rep "done") + (loop (nn-recv rep) + (if (> (- (current-seconds) last-print) 15) + (begin + (print "Processed " (hash-table-size p1dat) ", " (hash-table-size p2dat)) + (current-seconds)) + last-print))))) + (print "p1: " (hash-table-size p1dat) " p2: " (hash-table-size p2dat)) + (hash-table-for-each + p1dat + (lambda (k v) + (if (not (hash-table-exists? p2dat k)) + (print "REMOVED: " k)))) + (hash-table-for-each + p2dat + (lambda (k v) + (if (not (hash-table-exists? p1dat k)) + (print "ADDED: " k)))) + (list p1dat p2dat))) + +(if (< (length (argv)) 2) + (begin + (print "Usage: remotediff-nmsg file1 file2") + (exit))) + +(if (eq? (length (argv)) 2) ;; given a single path + (gather-dir-info (cadr (argv))) + (compare-directories (cadr (argv))(caddr (argv)))) + +(print "Done") Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -283,11 +283,11 @@ (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) - + (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) ;; (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) (res (case (rmt:run-id->transport-type run-id) ((http) @@ -381,14 +381,23 @@ ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) - (rmt:send-receive 'get-keys #f '())) + (if *db-keys* *db-keys* + (let ((res (rmt:send-receive 'get-keys #f '()))) + (set! *db-keys* res) + res))) +;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe +;; to cache the resuls in a hash +;; (define (rmt:get-key-vals run-id) - (rmt:send-receive 'get-key-vals #f (list run-id))) + (or (hash-table-ref/default *keyvals* run-id #f) + (let ((res (rmt:send-receive 'get-key-vals #f (list run-id)))) + (hash-table-set! *keyvals* run-id res) + res))) (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -396,13 +396,12 @@ ;;============================================================= (thread-start! th1) (set! db *inmemdb*) (debug:print 0 *default-log-port* "Server started on " host:port) - - (thread-sleep! 5) + ;; (thread-sleep! 5) (if (rpc-transport:self-test run-id ipaddrstr portnum) (debug:print 0 *default-log-port* "INFO: rpc self test passed!") (begin (debug:print 0 *default-log-port* "Error: rpc listener did not pass self test. Shutting down. On: " host:port) (exit))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1324,11 +1324,11 @@ ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) - (BB> "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -48,34 +48,34 @@ cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep test2 : fullprep - cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) - cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) - cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) - cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) - cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) - sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) + cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none -runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) + cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none -runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none -runname $(RUNAME)_02 -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none -runname $(RUNNAME)_02 -debug $(DEBUG) + cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none -runname $(RUNNAME)_03 -debug $(DEBUG) + sleep 40;cd fullrun;megatest -target ubuntu/nfs/none -runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) test3 : fullprep test3a test3b test3a : @echo Run runfirst and any waitons. - cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b test3b : @echo Run all_toplevel and all waitons - cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c + cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_c test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" - cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -run -testpatt % -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) test4a : cleanprep - cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -run -testpatt all_toplevel -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) # NOTE: Only one instance can be a server test5 : cleanprep rm -f fullrun/a*.log fullrun/logs/* @echo "WARNING: No longer running fullprep, test converage may be lessened" Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -32,11 +32,13 @@ # and set the dbdir to /var/tmp/$USER/mt_db to enable keeping # the raw db in /var/tmp/$USER # faststart no monitordir #{getenv MT_RUN_AREA_HOME}/db -dbdir #{getenv MT_RUN_AREA_HOME}/db +dbdirdefn /tmp/#{getenv USER}/#{getenv MT_TESTSUITE_NAME}/db +dbdirmkdir #{scheme (create-directory "#{get setup dbdirdefn}" #t)} +dbdir #{get setup dbdirdefn} # sync more aggressively to megatest-db megatest-db yes # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding Index: utils/viewscreen ================================================================== --- utils/viewscreen +++ utils/viewscreen @@ -14,6 +14,6 @@ screen -X hardstatus alwayslastline screen -X hardstatus string '%{= kG}[ %{G}%H %{g}][%= %{= kw}%?%-Lw%?%{r}(%{W}%n*%f%t%?(%u)%?%{r})%{w}%?%+Lw%?%?%= %{g}][%{B} %m-%d %{W} %c %{g}]' fi cmd="cd $PWD;$*" -screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f to see other windows\";bash -c 'read -n 1 -s'" +screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f to see other windows\";bash -c 'read -n 1 -s'" &