ADDED DONE
Index: DONE
==================================================================
--- /dev/null
+++ DONE
@@ -0,0 +1,36 @@
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Megatest. If not, see .
+
+NOTE: This file gets copied occasionally into the wiki as "Roadmap DONE".
+ Do not make changes in the wiki, they will be lost!
+
+DONE
+====
+
+WW14
+. Streamline compilation - DONE, all non-official egg modules are now bundled.
+
+WW15
+. syscheck; touch file in home, tmp, runs, links and start xterm [DONE]
+
+WW16
+. archiving improvements/extentions [DONE]
+.. -get-data, -put-data [DONE]
+.. use MT_ vars if defined and no switch present [DONE]
+.. fix archive "first run" bug [DONE]
+.. areas path1 path2 ... -> search path for archives [NOT NEEDED - use -start-dir]
+.. -propagate -> move archive data forward when it is found in older bundles [NOT NEEDED - simply repost the data]
Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -17,11 +17,10 @@
# 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)
-CHICKEN_PREFIX=$(PWD)/new-chicken/
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 \
@@ -62,22 +61,16 @@
ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif
-CSIPATH=$(shell which csi)
-CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
-# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")
PNGFILES = $(shell cd docs/manual;ls *png)
-#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
-# megatest.o : ducttape-lib.import.o
-
mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES)
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
@@ -89,10 +82,11 @@
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
+include makefile.inc
TCMTOBJS = \
api.o \
archive.o \
cgisetup/models/pgdb.o \
@@ -213,53 +207,55 @@
csc $(CSCOPTS) -c common.scm mofiles/commonmod.o
configf.o : configf.scm mofiles/commonmod.o
csc $(CSCOPTS) -c configf.scm mofiles/commonmod.o
-$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtest : mtest
@echo Installing to PREFIX=$(PREFIX)
- $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
+ $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest
+
+$(PREFIX)/bin/megatest : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
chmod a+x $(PREFIX)/bin/megatest
-$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
- $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
+$(PREFIX)/bin/.$(ARCHSTR)/bin/ndboard : ndboard
+ $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/bin/ndboard
$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
chmod a+x $(PREFIX)/bin/newdashboard
# mtutil
-$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
- $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtut : mtut
+ $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut
install-mtut : mtut
$(INSTALL) mtut $(PREFIX)/bin/mtut
-$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper
+$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil
chmod a+x $(PREFIX)/bin/mtutil
# mtexec
mtexec: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtexec.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtexec.scm -o mtexec
-$(PREFIX)/bin/.$(ARCHSTR)/mtexec : mtexec
- $(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/mtexec
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec : mtexec
+ $(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec
-$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper
+$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec
chmod a+x $(PREFIX)/bin/mtexec
# tcmt
-$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
- $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt
+$(PREFIX)/bin/.$(ARCHSTR)/bin/tcmt : tcmt
+ $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/bin/tcmt
-$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
+$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/bin/tcmt utils/mk_wrapper
utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
chmod a+x $(PREFIX)/bin/tcmt
$(PREFIX)/bin/mt_laststep : utils/mt_laststep
$(INSTALL) $< $@
@@ -317,26 +313,29 @@
make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR)
mtest-reaper: $(PREFIX)/bin/mtest-reaper
# install dashboard as dboard so wrapper script can be called dashboard
-$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
+$(PREFIX)/bin/.$(ARCHSTR)/bin/dboard : dboard $(FILES)
+ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/bin/dboard
+
+$(PREFIX)/bin/dashboard : $(PREFIX)/bin/.$(ARCHSTR)/bin/dboard utils/mk_wrapper
utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
- $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
-install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
- $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
- $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
+install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest $(PREFIX)/bin/megatest \
+ $(PREFIX)/bin/.$(ARCHSTR)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
+ $(PREFIX)/bin/.$(ARCHSTR)/bin/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
$(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
+ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/bin
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
test: tests/tests.scm
cd tests;csi -I .. -b -n tests.scm
@@ -445,105 +444,10 @@
unit :
cd tests;make unit
-#======================================================================
-# Chicken build
-#======================================================================
-
-tgz/sqlite-autoconf-3090200.tar.gz :
- mkdir -p tgz
- curl http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz > tgz/sqlite-autoconf-3090200.tar.gz
-
-tgz/nanomsg-1.0.0.tar.gz :
- wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz
- mv 1.0.0.tar.gz tgz/nanomsg-1.0.0.tar.gz
-
-tgz/chicken-4.13.0.tar.gz :
- mkdir -p tgz
- curl https://code.call-cc.org/releases/4.13.0/chicken-4.13.0.tar.gz > tgz/chicken-4.13.0.tar.gz
-
-tgz/ffcall.tar.gz :
- wget -c -O tgz/ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk'
-
-$(CHICKEN_PREFIX)/sqlite-autoconf-3090200/configure : tgz/sqlite-autoconf-3090200.tar.gz
- mkdir -p build;
- cd build; tar xf ../tgz/sqlite-autoconf-3090200.tar.gz
-
-$(CHICKEN_PREFIX)/lib/libnanomsg.so : tgz/nanomsg-1.0.0.tar.gz
- cd tgz; tar -xzvf nanomsg-1.0.0.tar.gz
- cd tgz/nanomsg-1.0.0; mkdir build; cd build;
- cd tgz/nanomsg-1.0.0/build; cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX)
- cd tgz/nanomsg-1.0.0/build; make; make install
-
-$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz/chicken-4.13.0.tar.gz
- mkdir -p build/eggs-installed
- cd build;tar xf ../tgz/chicken-4.13.0.tar.gz
-
-tgz/opensrc.fossil :
- cd tgz; fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
- mkdir tgz/opensrc
- cd tgz/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync
-
-$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz/opensrc.fossil
- cd tgz/opensrc; fossil unversioned cat libs/cd/cd-5.10_Linux26g4_64_lib.tar.gz > ../cd.tgz
- cd tgz/opensrc; fossil unversioned cat libs/im/im-3.11_Linux26g4_64_lib.tar.gz > ../im.tgz
- cd tgz/opensrc; fossil unversioned cat libs/iup/iup-3.19.1_Linux26g4_64_lib.tar.gz > ../iup.tgz
- cd tgz; tar -xzf cd.tgz;
- cd tgz; tar -xzf im.tgz;
- cd tgz; tar -xzf iup.tgz;
- cp tgz/include/* $(CHICKEN_PREFIX)/include/
- cp tgz/*.so $(CHICKEN_PREFIX)/lib/
- cp tgz/*.a $(CHICKEN_PREFIX)/lib/
- cp tgz/ftgl/lib/*/* $(CHICKEN_PREFIX)/lib/
-
-EGGS=srfi-69 srfi-42 sqlite3 iup canvas-draw typed-records md5 regex-case base64 \
-format dot-locking csv-xml z3 udp hostinfo directory-utils stack dbi crypt sha1 \
-posix-extras pathname-expand csv call-with-environment-variables s11n spiffy \
-uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing \
-ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19 sparse-vectors \
-sql-de-lite fmt readline apropos json simple-exceptions rpc trace logpro refdb
-EGGSTARG=$(addsuffix .done,$(addprefix build/eggs-installed/,$(EGGS)))
-EGGSTARG2=$(addsuffix .done, $(EGGS))
-
-$(CHICKEN_PREFIX)/lib/libcallback.a : tgz/ffcall.tar.gz
- cd tgz; tar -xzvf ffcall.tar.gz
- cd tgz/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared
- cd tgz/ffcall; make CC="gcc -fPIC"; make install
-
-$(CHICKEN_PREFIX)/bin/sqlite3 : build/sqlite-autoconf-3090200/configure
- cd build/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install
-
-$(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE
- cd build/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX)
- cd build/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install
-
-chicken : $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2)
- echo "Fake target to build prefix chicken"
-
-nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so
- CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done
-
-iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a
- CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done
-
-canvas-draw.done :
- CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done
-
-sqlite3.done :
- CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done
-
-sql-de-lite.done :
- CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done
-
-%.done :
- $(CHICKEN_PREFIX)/bin/chicken-install $* > $*.done
-
-build/eggs-installed/%.done : build/bin/csi $(EGGS)
- $(CHICKEN_PREFIX)/bin/chicken-install $* > build/eggs-installed/$*.done
-
#======================================================================
# Attic
#======================================================================
# portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -16,31 +16,25 @@
# along with Megatest. If not, see .
NOTE: This file gets copied occasionally into the wiki as "Roadmap".
Do not make changes in the wiki, they will be lost!
+See the file "DONE" to see completed items.
+
TODO
====
-WW14
-. Streamline compilation - DONE, all non-official egg modules are now bundled.
-
WW15
. syscheck; touch file in home, tmp, runs, links and start xterm [DONE]
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling
WW16
. split db into megatest.db (runs etc.) db/.db
. release basic newview implementation
-. archiving improvements/extentions
.. -get-data, -put-data [DONE]
.. get and put to specific paths
-.. use MT_ vars if defined and no switch present
-.. fix archive "first run" bug
-.. areas path1 path2 ... -> search path for archives
-.. -propagate -> move archive data forward when it is found in older bundles
WW18
. release split db implementation
. mtutil calls from dashboard (for remote control)
. logs browser (esp. for surfacing mtutil related activities)
@@ -48,10 +42,13 @@
WW19
. break command line into sections; all, run control, queries, utilities etc.
. pull in ftfplan (not integrated, just code pulled in)
WW20
+. ./configure => ubuntu, sles11, sles12, rh7
+. Jenkins junit XML support
+. Add output flushing in teamcity support
. Switch to using simple runs query everywhere
. Add end_time to runs and add a rollup call that sets state, status and end_time
Future
. Switch to scsh-process pipeline management for job execution/control
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -90,11 +90,11 @@
(pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
(apath (if pscript
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: script \"" pscript-cmd "\" failed to run properly.")
+ (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly.")
(exit 1))
(with-input-from-pipe
pscript-cmd
read-line))
#f)) ;; this is the user-calculated archive path
@@ -116,13 +116,16 @@
;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
(if block-id ;; (and block-id allocation-id)
(let ((res (cons block-id archive-path)))
(hash-table-set! blockid-cache key res)
res)
- #f))
- #f)) ;; no best disk found
- )))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", archive-path=" archive-path)
+ #f)))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", block-id=" block-id)
+ #f)))))) ;; no best disk found
;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
@@ -246,11 +249,20 @@
(arch-group (hash-table-ref arch-groups test-base))
(arch-info (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
(archive-id (car arch-info))
(archive-dir (cdr arch-info)))
(debug:print 0 *default-log-port* "Processing disk-group " test-base)
- (let* ((test-paths (hash-table-ref disk-groups test-base)))
+ (let* ((test-paths-in (hash-table-ref disk-groups test-base))
+ (test-paths (if (args:get-arg "-include")
+ (let ((subpaths (string-split (args:get-arg "-include") ",")))
+ (apply append
+ (map (lambda (p)
+ (map (lambda (subp)
+ (conc p "/" subp))
+ subpaths))
+ test-paths-in)))
+ test-paths-in)))
(if (not (common:file-exists? archive-dir))
(create-directory archive-dir #t))
(case archiver
((bup) ;; Archive using bup
(let* ((bup-init-params (list "-d" archive-dir "init"))
@@ -343,11 +355,14 @@
(archive-block-id (db:test-get-archived test-dat))
(archive-block-info (rmt:test-get-archive-block-info archive-block-id))
(archive-path (if (vector? archive-block-info)
(vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
#f)) ;; no archive found?
- (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))
+ (include-paths (args:get-arg "-include"))
+ (exclude-pattern (args:get-arg "-exclude-rx"))
+ (exclude-file (args:get-arg "-exclude-rx-from")))
;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
;;
(if (and (not toplevel/children) ;; special handling needed for toplevel with children
prev-test-physical-path
@@ -440,18 +455,25 @@
(archive-block-info (rmt:test-get-archive-block-info archive-block-id))
(archive-path (if (vector? archive-block-info)
(vector-ref archive-block-info 2)
#f))
(archive-internal-path (conc (common:get-testsuite-name) "-" run-id
- "/latest/" test-partial-path)))
+ "/latest/" test-partial-path))
+ (include-paths (args:get-arg "-include"))
+ (exclude-pattern (args:get-arg "-exclude-rx"))
+ (exclude-file (args:get-arg "-exclude-rx-from")))
(if (and archive-path ;; no point in proceeding if there is no actual archive
(not toplevel/children))
(begin
- (let* ((bup-restore-params (list "-d" archive-path "restore" "-C" (or destpath "data")
- ;; " " ;; What is the empty string for?
- archive-internal-path)))
+ (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
+ ;; " " ;; What is the empty string for?
+ (if include-paths
+ (map (lambda (p)
+ (conc archive-internal-path "/" p))
+ (string-split include-paths ","))
+ (list archive-internal-path)))))
(debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
" from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
(let ((new-rem-tests (filter (lambda (tdat)
(or (not (eq? (db:test-get-id tdat) test-id))
ADDED chicken.makefile
Index: chicken.makefile
==================================================================
--- /dev/null
+++ chicken.makefile
@@ -0,0 +1,157 @@
+
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Megatest. If not, see .
+
+
+#======================================================================
+# Chicken build
+#======================================================================
+
+# CHICKEN_BIN_DIR=$(shell dirname $(shell which csi))
+# if have csi on path use that, else use default
+# CSIPATH=$(shell which csi)
+# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
+sCHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR))
+
+whatever :
+ @echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)"
+
+tgz-$(USER)/postgresql-9.6.4.tar.gz :
+ mkdir -p tgz-$(USER)
+ wget -c https://ftp.postgresql.org/pub/source/v9.6.4/postgresql-9.6.4.tar.gz
+ mv postgresql-9.6.4.tar.gz tgz-$(USER)/
+
+tgz-$(USER)/sqlite-autoconf-3090200.tar.gz :
+ mkdir -p tgz-$(USER)
+ curl http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz > tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
+
+tgz-$(USER)/nanomsg-1.0.0.tar.gz :
+ wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz
+ mv 1.0.0.tar.gz tgz-$(USER)/nanomsg-1.0.0.tar.gz
+
+tgz-$(USER)/chicken-4.13.0.tar.gz :
+ mkdir -p tgz-$(USER)
+ curl https://code.call-cc.org/releases/4.13.0/chicken-4.13.0.tar.gz > tgz-$(USER)/chicken-4.13.0.tar.gz
+
+tgz-$(USER)/ffcall.tar.gz :
+ wget -c -O tgz-$(USER)/ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk'
+
+$(CHICKEN_PREFIX)/bin/pg_config : tgz-$(USER)/postgresql-9.6.4.tar.gz
+ mkdir -p build-$(USER)/
+ tar xfz tgz-$(USER)/postgresql-9.6.4.tar.gz -C build-$(USER)
+ cd build-$(USER)/postgresql-9.6.4; ./configure --prefix=$(CHICKEN_PREFIX) --with-openssl; make; make install
+
+build-$(USER)/sqlite-autoconf-3090200/configure : tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
+ mkdir -p build-$(USER);
+ cd build-$(USER); tar xf ../tgz-$(USER)/sqlite-autoconf-3090200.tar.gz
+
+$(CHICKEN_PREFIX)/lib/libnanomsg.so : tgz-$(USER)/nanomsg-1.0.0.tar.gz
+ cd tgz-$(USER); tar -xzvf nanomsg-1.0.0.tar.gz
+ cd tgz-$(USER)/nanomsg-1.0.0; mkdir build-$(USER); cd build-$(USER);
+ cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); cmake ../ -DCMAKE_INSTALL_PREFIX=$(CHICKEN_PREFIX)
+ cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install
+
+$(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz
+ mkdir -p build-$(USER)/eggs-installed
+ cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz
+
+tgz-$(USER)/opensrc.fossil :
+ cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+ mkdir tgz-$(USER)/opensrc
+ cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync
+
+$(CHICKEN_PREFIX)/lib/libiupweb.so : tgz-$(USER)/opensrc.fossil
+ cd tgz-$(USER)/opensrc; fossil unversioned cat libs/cd/cd-5.10_Linux26g4_64_lib.tar.gz > ../cd.tgz
+ cd tgz-$(USER)/opensrc; fossil unversioned cat libs/im/im-3.11_Linux26g4_64_lib.tar.gz > ../im.tgz
+ cd tgz-$(USER)/opensrc; fossil unversioned cat libs/iup/iup-3.19.1_Linux26g4_64_lib.tar.gz > ../iup.tgz
+ cd tgz-$(USER); tar -xzf cd.tgz;
+ cd tgz-$(USER); tar -xzf im.tgz;
+ cd tgz-$(USER); tar -xzf iup.tgz;
+ cp tgz-$(USER)/include/* $(CHICKEN_PREFIX)/include/
+ cp tgz-$(USER)/*.so $(CHICKEN_PREFIX)/lib/
+ cp tgz-$(USER)/*.a $(CHICKEN_PREFIX)/lib/
+ cp tgz-$(USER)/ftgl/lib/*/* $(CHICKEN_PREFIX)/lib/
+
+EGGS=srfi-69 srfi-42 sqlite3 iup canvas-draw typed-records md5 regex-case base64 \
+format dot-locking csv-xml z3 udp hostinfo directory-utils stack dbi crypt sha1 \
+posix-extras pathname-expand csv call-with-environment-variables s11n spiffy \
+uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing \
+ansi-escape-sequences test slice rfc3339 uuid-lib filepath srfi-19 sparse-vectors \
+sql-de-lite fmt readline apropos json simple-exceptions rpc trace logpro refdb postgresql nanomsg
+EGGSTARG=$(addsuffix .done,$(addprefix build-$(USER)/eggs-installed/,$(EGGS)))
+EGGSTARG2=$(addsuffix .done, $(EGGS))
+
+$(CHICKEN_PREFIX)/lib/libcallback.a : tgz-$(USER)/ffcall.tar.gz
+ cd tgz-$(USER); tar -xzvf ffcall.tar.gz
+ cd tgz-$(USER)/ffcall; ./configure --prefix=$(CHICKEN_PREFIX) --enable-shared
+ cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install
+
+$(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure
+ cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install
+
+$(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE
+ cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX)
+ cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install
+
+ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump \
+chicken-install chicken-profile chicken-sqlite3 chicken-status \
+chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro \
+refdb
+
+CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN))
+
+$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2)
+ utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$*
+ chmod a+x $(PREFIX)/bin/$*
+
+$(PREFIX)/bin :
+ mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin
+
+chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi binwrappers
+ @echo "Fake target to build prefix chicken"
+
+binwrappers : $(CKBIN_WRAPPERS)
+
+postgresql.done : $(CHICKEN_PREFIX)/bin/pg_config
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done
+
+nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done
+
+iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done
+
+canvas-draw.done :
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done
+
+sqlite3.done :
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done
+
+sql-de-lite.done :
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done
+
+dbi.done : postgresql.done sqlite3.done sql-de-lite.done
+ CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install dbi > dbi.done
+
+%.done :
+ $(CHICKEN_PREFIX)/bin/chicken-install $* > $*.done
+
+build-$(USER)/eggs-installed/%.done : $(CHICKEN_PREFIX)/bin/csi $(EGGS)
+ $(CHICKEN_PREFIX)/bin/chicken-install $* > build-$(USER)/eggs-installed/$*.done
+
+build-clean :
+ rm -rf build-$(USER) bin
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -228,10 +228,32 @@
(fullpath (realpath this-script)))
fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
+
+;; when called from a wrapper I need sometimes to find the calling
+;; wrapper, this is for dashboard to find the correct megatest.
+;;
+(define (common:find-local-megatest #!optional (progname "megatest"))
+ (let ((res (filter file-exists?
+ (map (lambda (updir)
+ (let* ((lm (car (argv)))
+ (dir (pathname-directory lm))
+ (exe (pathname-strip-directory lm)))
+ (conc (if dir (conc dir "/") "")
+ (case (string->symbol exe)
+ ((dboard) (conc updir progname))
+ ((mtest) (conc updir progname))
+ ((dashboard) progname)
+ (else exe)))))
+ '("../../" "../")))))
+ (if (null? res)
+ (begin
+ (debug:print 0 *current-log-port* "Failed to find this executable! Using what can be found on the path")
+ progname)
+ (car res))))
(define *common:logpro-exit-code->status-sym-alist*
'( ( 0 . pass )
( 1 . fail )
( 2 . warn )
@@ -1744,11 +1766,11 @@
;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)
(handle-exceptions
exn
- '(99 99 99)
+ '(-99 -99 -99)
(let* ((actual-hostname (or remote-host (get-host-name) "localhost")))
(or (common:get-cached-info actual-hostname "cpu-load")
(let ((result (if remote-host
(map (lambda (res)
(if (eof-object? res) 9e99 res))
@@ -1755,12 +1777,21 @@
(with-input-from-pipe
(conc "ssh " remote-host " cat /proc/loadavg")
(lambda ()(list (read)(read)(read)))))
(with-input-from-file "/proc/loadavg"
(lambda ()(list (read)(read)(read)))))))
- (common:write-cached-info actual-hostname "cpu-load" result)
- result)))))
+ (match
+ result
+ ((l1 l2 l3)
+ (if (and (number? l1)
+ (number? l2)
+ (number? l3))
+ (begin
+ (common:write-cached-info actual-hostname "cpu-load" result)
+ result)
+ '(-1 -1 -1))) ;; -1 is bad result
+ (else '(-2 -2 -2))))))))
;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
@@ -2006,38 +2037,63 @@
(common:wait-for-normalized-load maxload msg remote-host (- rem-tries 1))
#f)))))
;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
;;
-(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f))
+(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
(let* ((loadavg (common:get-cpu-load remote-host))
(numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again
(common:get-num-cpus remote-host)
numcpus-in))
(maxload (if force-maxload
maxload-in
(max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
(first (car loadavg))
(next (cadr loadavg))
- (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
+ (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
+ ;; numcpus (or could be
+ ;; maxload) is zero,
+ ;; crude fallback is to
+ ;; at least use 1
(loadjmp (- first next))
- (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) )) )));; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
- ;; let's let the user know once in a long while that load checking is happening but not constantly report it
+ ;; add some randomness to the time to break any alignment
+ ;; where netbatch dumps many jobs to machines simultaneously
+ (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)
+ (/ (- 1000 count) 10)
+ waitdelay)
+ (- first adjmaxload) )) )))
+ ;; let's let the user know once in a long while that load checking
+ ;; is happening but not constantly report it
(if (> (random 100) 75) ;; about 25% of the time
(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
- ", load: " first ", adjload: " adjload ", loadjmp: " loadjmp))
+ ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
(cond
- ((and (> first adjload)
+ ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
+ (> num-tries 0))
+ (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
+ (thread-sleep! 10)
+ (common:wait-for-cpuload maxload-in numcpus-in waitdelay
+ count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
+ ((and (> first adjmaxload)
(> count 0))
- (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
+ (debug:print-info 0 *default-log-port*
+ "server start delayed " adjwait
+ " seconds due to load " first
+ " exceeding max of " adjmaxload
+ " on server " (or remote-host (get-host-name))
+ " (normalized load-limit: " maxload ") " (if msg msg ""))
(thread-sleep! adjwait)
(common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
((and (> loadjmp numcpus)
(> count 0))
(debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
(thread-sleep! adjwait)
- (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))
+ (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
+ (else
+ (if (> num-tries 0)
+ (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing.")
+ (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
(define (get-uname . params)
(let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
(uname #f))
(if (null? (car uname-res))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -193,11 +193,11 @@
((return-string)
inl)
(else
(configf:process-line inl ht allow-processing)))))
(if (and (string? res)
- (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "yes")))
(string-substitute "\\s+$" "" res)
res))))))
(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
(filter
ADDED configure
Index: configure
==================================================================
--- /dev/null
+++ configure
@@ -0,0 +1,100 @@
+#!/bin/bash
+
+# Copyright 2006-2017, Matthew Welland.
+#
+# This file is part of Megatest.
+#
+# Megatest is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# Megatest is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Megatest. If not, see .
+
+# Configure the build
+
+if [[ "$1"x == "x" ]];then
+ PREFIX=$PWD
+else
+ PREFIX=$1
+fi
+
+
+#======================================================================
+# Configure stuff needed for eggs
+#======================================================================
+
+function configure_dependencies () {
+
+ #======================================================================
+ # libnanomsg
+ #======================================================================
+
+ if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
+ echo "libnanomsg build needed."
+ echo "BUILD_NANOMSG=yes" >> makefile.inc
+ fi
+
+ #======================================================================
+ # postgresql libraries
+ #======================================================================
+
+ if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
+ echo "Postgresql build needed."
+ echo "BUILD_POSTGRES=yes" >> makefile.inc
+ fi
+
+ if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
+ echo "Sqlite3 build needed."
+ echo "BUILD_SQLITE3=yes" >> makefile.inc
+ fi
+
+}
+
+#======================================================================
+# Initialize makefile.inc
+#======================================================================
+
+echo "" > makefile.inc
+
+#======================================================================
+# Do we need Chicken?
+#======================================================================
+
+if [[ -e /usr/bin/sw_vers ]]; then
+ ARCHSTR=$(/usr/bin/sw_vers -productVersion)
+else
+ ARCHSTR=$(lsb_release -sr)
+fi
+
+echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
+CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR
+
+if [[ ! $(type csi) ]];then
+ echo "Chicken build needed."
+ echo "BUILD_CHICKEN=yes" >> makefile.inc
+ configure_dependencies
+ echo "include chicken.makefile" >> makefile.inc
+else
+ echo "CSIPATH=$(which csi)" >> makefile.inc
+ echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
+fi
+
+# Make setup scripts
+echo "#!/bin/bash" > setup.sh
+echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
+echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
+echo 'exec "$@"' >> setup.sh
+chmod a+x setup.sh
+
+echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
+echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh
+
+echo "All done creating makefile.inc, feel free to edit it!"
+echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -45,20 +45,13 @@
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (dboard:launch-testpanel run-id test-id)
- (let* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh"))
- ;; (cmd (conc
- ;; (if (common:file-exists? cfg-sh)
- ;; (conc "source "cfg-sh" && ")
- ;; "")
- ;; *common:this-exe-fullpath*
- ;; " -test " run-id "," test-id
- ;; " &"))
- (cmd (conc *common:this-exe-dir*"/../dashboard "
- "-test " run-id "," test-id
+ (let* ((dboardexe (common:find-local-megatest "dashboard"))
+ (cmd (conc dboardexe
+ " -test " run-id "," test-id
" &")))
(system cmd)))
(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -102,10 +102,11 @@
"-q"
"-use-db-cache"
"-skip-version-check"
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
+ "-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
;; check for MT_* environment variables and exit if found
@@ -1483,11 +1484,11 @@
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
- ;; refer to (dboard:tabcodat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
+ ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
(let* ((result
(iup:vbox
(dcommon:command-execution-control tabdat)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
@@ -2764,65 +2765,83 @@
(cell-width (dboard:tabdat-runs-cell-width runs-dat)))
;; controls (along bottom)
;; (set! controls (dboard:make-controls commondat runs-dat))
;; create the left most column for the run key names and the test names
- (set! lftlst (list (iup:hbox
- (iup:label) ;; (iup:valuator)
- (apply iup:vbox
- (map (lambda (x)
- (let ((res (iup:hbox #:expand "HORIZONTAL"
- (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL")
- (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL"
- #:action (lambda (obj unk val)
- ;; each field (field name is "x" var) live updates
- ;; the search filter as it is typed
- (dboard:tabdat-target-set! runs-dat #f) ;; ensure the fields text boxes are used and not the info from the tree
- (mark-for-update runs-dat)
- (update-search commondat runs-dat x val))))))
- (set! i (+ i 1))
- res))
- keynames)))))
+ (set! lftlst
+ (list (iup:hbox
+ (iup:label) ;; (iup:valuator)
+ (apply iup:vbox
+ (map (lambda (x)
+ (let ((res (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:label x
+ #:size (conc 40 btn-height)
+ #:fontsize btn-fontsz
+ #:expand "NO") ;; "HORIZONTAL")
+ (iup:textbox
+ #:size (conc 35 btn-height)
+ #:fontsize btn-fontsz
+ #:value "%"
+ #:expand "NO" ;; "HORIZONTAL"
+ #:action (lambda (obj unk val)
+ ;; each field
+ ;; (field name is "x" var) live updates
+ ;; the search filter as it is typed
+ (dboard:tabdat-target-set! runs-dat #f)
+ ;; ensure fields text boxes are used
+ ;; and not the info from the tree
+ (mark-for-update runs-dat)
+ (update-search commondat runs-dat x val))))))
+ (set! i (+ i 1))
+ res))
+ keynames)))))
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
(set! lftlst
- (append lftlst
- (list (iup:hbox
- #:expand "HORIZONTAL"
- (iup:valuator
- #:valuechanged_cb (lambda (obj)
- (let ((val (string->number (iup:attribute obj "VALUE")))
- (oldmax (string->number (iup:attribute obj "MAX")))
- (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
- (dboard:commondat-please-update-set! commondat #t)
- (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
- (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) "
- (dboard:tabdat-start-test-offset runs-dat) " val: " val
- " newmax: " newmax " oldmax: " oldmax)
- (if (< val 10)
- (iup:attribute-set! obj "MAX" newmax))
- ))
- #:expand "VERTICAL"
- #:orientation "VERTICAL"
- #:min 0
- #:step 0.01)
- (apply iup:vbox (reverse res)))))))
+ (append
+ lftlst
+ (list
+ (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:valuator
+ #:valuechanged_cb
+ (lambda (obj)
+ (let ((val (string->number (iup:attribute obj "VALUE")))
+ (oldmax (string->number (iup:attribute obj "MAX")))
+ (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-start-test-offset-set! runs-dat
+ (inexact->exact (round (/ val 10))))
+ (debug:print 6 *default-log-port*
+ "(dboard:tabdat-start-test-offset runs-dat) "
+ (dboard:tabdat-start-test-offset runs-dat) " val: " val
+ " newmax: " newmax " oldmax: " oldmax)
+ (if (< val 10)
+ (iup:attribute-set! obj "MAX" newmax))
+ ))
+ #:expand "VERTICAL"
+ #:orientation "VERTICAL"
+ #:min 0
+ #:step 0.01)
+ (apply iup:vbox (reverse res)))))))
(else
- (let ((labl (iup:button "" ;; the testname labels
- #:flat "YES"
- #:alignment "ALEFT"
+ (let ((labl (iup:button
+ "" ;; the testname labels
+ #:flat "YES"
+ #:alignment "ALEFT"
; #:image img1
; #:impress img2
- #:size (conc cell-width btn-height)
- #:expand "HORIZONTAL"
- #:fontsize btn-fontsz
- #:action (lambda (obj)
- (mark-for-update runs-dat)
- (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE"))))
+ #:size (conc cell-width btn-height)
+ #:expand "HORIZONTAL"
+ #:fontsize btn-fontsz
+ #:action (lambda (obj)
+ (mark-for-update runs-dat)
+ (toggle-hide testnum (dboard:commondat-uidat commondat))))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
;; These are the headers for each row
(let loop ((runnum 0)
(keynum 0)
@@ -2920,11 +2939,11 @@
(dashboard:runs-horizontal-slider runs-dat))))
controls
))
(views-cfgdat (common:load-views-config))
(additional-tabnames '())
- (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
+ (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
;; (data (dboard:tabdat-init (make-d:data)))
(additional-views ;; process views-dat
(let ((tab-num tab-start-num)
(result '()))
(for-each
@@ -2931,55 +2950,54 @@
(lambda (view-name)
(debug:print 0 *default-log-port* "Adding view " view-name)
(let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view?
(if (not (string? cfgtype))
(debug:print-info 0 *default-log-port* "WARNING: view \"" view-name
- "\" is missing needed sections. Please consult the documenation and update ~/.mtviews.config or " *toppath* "/.mtviews.config")
+ "\" is missing needed sections. "
+ "Please consult the documenation and update ~/.mtviews.config or "
+ *toppath* "/.mtviews.config")
(case (string->symbol cfgtype)
;; user supplied source for a tab
;;
- ((external)
- (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) ;; was tabs
+ ((external) ;; was tabs
+ (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num)))
(set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames))
(set! tab-num (+ tab-num 1))
(set! result (append result (list tab-content)))))))))
- (sort (hash-table-keys views-cfgdat) (lambda (a b)
- (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
- (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
- (> order-a order-b)))))
+ (sort (hash-table-keys views-cfgdat)
+ (lambda (a b)
+ (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
+ (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
+ (> order-a order-b)))))
result))
(tabs (apply iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(debug:catch-and-dump
(lambda ()
(let* ((tab-num (dboard:commondat-curr-tab-num commondat))
(tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
-
(dboard:tabdat-layout-update-ok-set! tabdat #f))
(dboard:commondat-curr-tab-num-set! commondat curr)
(let* ((tab-num (dboard:commondat-curr-tab-num commondat))
(tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
-
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-layout-update-ok-set! tabdat #t)))
"tabchangepos"))
(dashboard:summary commondat stats-dat tab-num: 0)
runs-view
- (make-runs-view commondat runs2-dat 2)
- (dashboard:runs-summary commondat onerun-dat tab-num: 3)
- ;; (dashboard:new-view db data new-view-dat tab-num: 3)
- (dashboard:run-controls commondat runcontrols-dat tab-num: 4)
- (dashboard:run-times commondat runtimes-dat tab-num: 5)
- ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
+ ;; (make-runs-view commondat runs2-dat 2)
+ (dashboard:runs-summary commondat onerun-dat tab-num: 2)
+ (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
+ (dashboard:run-times commondat runtimes-dat tab-num: 4)
additional-views)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
- (iup:attribute-set! tabs "TABTITLE2" "Runs2")
- (iup:attribute-set! tabs "TABTITLE3" "Run Summary")
- (iup:attribute-set! tabs "TABTITLE4" "Run Control")
- (iup:attribute-set! tabs "TABTITLE5" "Run Times")
+ ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
+ (iup:attribute-set! tabs "TABTITLE2" "Run Summary")
+ (iup:attribute-set! tabs "TABTITLE3" "Run Control")
+ (iup:attribute-set! tabs "TABTITLE4" "Run Times")
;; (iup:attribute-set! tabs "TABTITLE3" "New View")
;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
;; set the tab names for user added tabs
(for-each
@@ -2991,10 +3009,11 @@
;; make the iup tabs object available (for changing color for example)
(dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
;; now set up the tabdat lookup
(dboard:common-set-tabdat! commondat 0 stats-dat)
(dboard:common-set-tabdat! commondat 1 runs-dat)
+ ;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
(dboard:common-set-tabdat! commondat 2 onerun-dat)
(dboard:common-set-tabdat! commondat 3 runcontrols-dat)
(dboard:common-set-tabdat! commondat 4 runtimes-dat)
(iup:vbox
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1464,20 +1464,18 @@
(set! res id))
db
"SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
bdisk-id archive-path)
(if res ;; record exists, update du if applicable and return res
- (begin
- (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
+ (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
WHERE archive_disk_id=? AND disk_path=?;"
- bdisk-id archive-path du))
- res)
+ bdisk-id archive-path du))
(begin
(sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
VALUES (?,?,?);"
bdisk-id archive-path (or du 0))
- (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))
+ (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
res))
;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
-
+
The Megatest Users Manual