Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -21,21 +21,21 @@
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm margs.scm \
- megatest-version.scm process.scm runs.scm tasks.scm \
- tests.scm genexample.scm http-transport.scm filedb.scm \
- tdb.scm client.scm mt.scm ezsteps.scm lock-queue.scm \
- sdb.scm rmt.scm api.scm subrun.scm portlogger.scm \
- archive.scm env.scm diff-report.scm \
- cgisetup/models/pgdb.scm
+ process.scm runs.scm tasks.scm tests.scm genexample.scm \
+ http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
+ ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
+ subrun.scm portlogger.scm archive.scm env.scm \
+ diff-report.scm cgisetup/models/pgdb.scm
# module source files
# ftail.scm rmtmod.scm commonmod.scm removed
MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
- mtargs.scm commonmod.scm dbmod.scm adjutant.scm
+ mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
+ rmtmod.scm apimod.scm
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
@@ -47,13 +47,15 @@
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
%.import.o : %.import.scm
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
-mofiles/%.o %.import.scm : %.scm
+# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
+mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm
@[ -e mofiles ] || mkdir -p mofiles
- csc $(CSCOPTS) -I $* -J -c $< -o mofiles/$*.o
+ csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
+ cp $*.o mofiles/$*.o
@touch $*.import.scm # ensure it is touched after the .o is made
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
@@ -73,17 +75,14 @@
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES)
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
-ndboard : newdashboard.scm $(OFILES) $(GOFILES)
- csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
-
-mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
+mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
include makefile.inc
TCMTOBJS = \
@@ -100,17 +99,14 @@
keys.o \
launch.o \
lock-queue.o \
margs.o \
mt.o \
- megatest-version.o \
ods.o \
portlogger.o \
process.o \
rmt.o \
- mofiles/rmtmod.o \
- rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
@@ -118,11 +114,11 @@
subrun.o \
ezsteps.o
# mofiles/commonmod.o \
-tcmt : $(TCMTOBJS) tcmt.scm
+tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm
csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
@@ -139,25 +135,29 @@
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
# Special dependencies for the includes
-common.o : mofiles/commonmod.o
+$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
+
+common.o : mofiles/commonmod.o megatest-fossil-hash.scm
+
+commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
tests.o db.o launch.o runs.o dashboard-tests.o \
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \
-monitor.o dashboard.o archive.o megatest.o : db_records.scm
+monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
-megatest.o : megatest-fossil-hash.scm
+megatest.o : megatest-fossil-hash.scm megatest-version.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
common_records.scm : altdb.scm
@@ -173,30 +173,32 @@
# special include based modules
mofiles/pkts.o : pkts/pkts.scm
mofiles/stml2.o : cookie.o
# mofiles/mtargs.o : mtargs/mtargs.scm
# mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
-# mofiles/ulex.o : ulex/ulex.scm
+mofiles/ulex.o : ulex/ulex.scm
mofiles/mutils.o : mutils/mutils.scm
mofiles/cookie.o : stml2/cookie.scm
mofiles/stml2.o : stml2/stml2.scm
# for the modularized stuff
rmt.o : mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o mofiles/mtargs.o
-megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
- echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
- if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
+mofiles/rmtmod.o : mofiles/apimod.o mofiles/ulex.o
+
+megatest-fossil-hash.scm : .fslckout
+ @echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
+ @if [[ ! -e megatest-fossil-hash.scm ]] || ! 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
# This having the full list of MOFILES cause everything to be rebuilt every time.
#
# %.o : %.scm $(MOFILES)
# csc $(CSCOPTS) -c $< $(MOFILES)
#
-%.o : %.scm
+%.o : %.scm megatest-fossil-hash.scm
csc $(CSCOPTS) -c $<
# specific rules for .o files that genuninely depend on mofiles/something
#
megatest.o : megatest.scm stml2.o mutils.o commonmod.o
@@ -209,27 +211,22 @@
csc $(CSCOPTS) -c common.scm mofiles/commonmod.o
configf.o : configf.scm mofiles/commonmod.o
csc $(CSCOPTS) -c configf.scm mofiles/commonmod.o
+$(PREFIX)/bin/.$(ARCHSTR)/bin/mtest : mtest
+
+$(PREFIX)/bin/megatest : $(PREFIX)/bin/.$(ARCHSTR)/bin/mtest utils/mk_wrapper
+
$(PREFIX)/bin/.$(ARCHSTR)/bin/mtest : mtest
@echo Installing to PREFIX=$(PREFIX)
$(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)/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)/bin/mtut : mtut
$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/bin/mtut
install-mtut : mtut
$(INSTALL) mtut $(PREFIX)/bin/mtut
@@ -349,13 +346,13 @@
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
- tcmt readline-fix.scm serialize-env dboard dboard.o \
- megatest.o dashboard.o megatest-fossil-hash.* altdb.scm \
- mofiles/*.o vg.o cookie.o dashboard-main.o \
+ tcmt readline-fix.scm serialize-env dboard *.o \
+ megatest-fossil-hash.* altdb.scm mofiles/*.o \
+ mofiles/*.o vg.o cookie.o dashboard-main.o \
ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o \
tcmt.o
rm -rf share
#======================================================================
@@ -398,19 +395,19 @@
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 megatest-version.o margs.o process.o common.o -o datashare-testing/spublish
+datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm
+ csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish
-datashare-testing/sretrieve : sretrieve.scm $(OFILES)
- csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o process.o common.o -o datashare-testing/sretrieve
+datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm
+ csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve
-datashare-testing/sauthorize : sauthorize.scm $(OFILES)
- csc $(CSCOPTS) sauthorize.scm megatest-version.o margs.o process.o common.o -o datashare-testing/sauthorize
+datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm
+ csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize
sauth-init:
mkdir -p datashare-testing
rm datashare-testing/sauthorize
rm datashare-testing/sretrieve
@@ -445,10 +442,30 @@
@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'
unit :
cd tests;make unit
+
+ALLSCMFILES=$(shell ls *scm|grep -v import)
+ALLREINDENT=$(addprefix reindent/,$(ALLSCMFILES))
+
+indentreport : reindentall
+ @for x in $(ALLSCMFILES);do if ! diff -q $$x reindent/$$x > /dev/null;then echo "FAIL $$x";fi;done
+
+reindentall : $(ALLREINDENT)
+ echo "ENSURE YOU HAVE THE LINES FROM emacs.config IN YOUR ~/.emacs FILE!"
+
+reindent/README :
+ mkdir -p reindent
+ echo "Indent modified files are put here." > reindent/README
+
+reindent/%.scm : %.scm reindent/README
+ cp $< reindent
+ cd reindent;emacs -batch $< --eval '(load "$(PWD)/reindent.el")' -f save-buffer
+
+# cd reindent;emacs -batch $< --eval '(indent-region (point-min) (point-max) nil)' -f save-buffer
+
#======================================================================
# Attic
#======================================================================
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -13,66 +13,10 @@
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
-NOTE: This file gets copied occasionally into the wiki as "Roadmap".
- Do not make changes in the wiki, they will be lost!
-
-See the file "DONE" to see completed items.
-FIXME
-====
-
-.dump
-----------------
-WARNING: disk disk0 at path "/mfs/tmp/archive" is not a directory - ignoring it.
-
-Warning (#): in thread: unbound variable: block-id
-
- Call history:
-
- common.scm:693: hash-table-ref/default
- common.scm:694: current-seconds
- common.scm:697: hash-table-set!
- common.scm:2232: debug:print
- common_records.scm:140: debug:debug-mode
- common_records.scm:141: with-output-to-port
- common.scm:2245: directory?
- common.scm:2246: common:low-noise-print
- common.scm:692: g2022
- common.scm:692: g2022
- common.scm:692: string-intersperse
- common.scm:693: hash-table-ref/default
- common.scm:694: current-seconds
- common.scm:2261: debug:print
- common_records.scm:140: debug:debug-mode
- archive.scm:125: debug:print <--
-INFO: (0) Estimating disk space usage for scriptinc/: 184
-
-Error: uncaught exception: #
-
- Call history:
-
- common.scm:1299: ##sys#get-keyword
- common.scm:1299: call-with-current-continuation
- common.scm:1299: with-exception-handler
- common.scm:1299: ##sys#call-with-values
- common.scm:1304: thunk
- common.scm:1310: file-exists?
- common.scm:1299: k2554
- common.scm:1299: g2558
- runs.scm:2438: common:get-disk-space-used
- common.scm:2128: conc
- common.scm:2128: with-input-from-pipe
- runs.scm:2438: debug:print-info
- common_records.scm:235: debug:debug-mode
- common_records.scm:236: port?
- common_records.scm:236: with-output-to-port
- runs.scm:2443: thread-join! <--
-Press any key to continue
-----------------
-
TODO
====
WW15
. fill newview matrix with data, filter pipeline gui elements
@@ -106,7 +50,9 @@
-------------------------------------
. Re-work the dbstruct data structure?
.. Move main.db to global?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
+. Re-work all queries to use run-id to dereference server
. Open main.db directly in calls to -runtests etc. No need to talk remote?
+. remove common:faux-lock
Index: adjutant.scm
==================================================================
--- adjutant.scm
+++ adjutant.scm
@@ -18,13 +18,12 @@
;;======================================================================
(declare (unit adjutant))
-(module adjutant
- *
-
+(module adjutant *
+
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
md5 message-digest
regex srfi-1)
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -81,11 +81,11 @@
tasks-get-last
testmeta-get-record
have-incompletes?
;; synchash-get
get-changed-record-ids
- get-run-record-ids
+ get-run-record-ids
get-not-completed-cnt))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
@@ -99,11 +99,11 @@
delete-test-records
delete-old-deleted-test-records
test-set-state-status
test-set-top-process-pid
set-state-status-and-roll-up-items
-
+
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
;; RUNS
register-run
@@ -120,10 +120,13 @@
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
+ drop-all-triggers
+ create-all-triggers
+ update-tesdata-on-repilcate-db
;; TESTMETA
testmeta-add-record
testmeta-update-field
@@ -213,11 +216,14 @@
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
((set-var) (apply db:set-var dbstruct params))
+ ((inc-var) (apply db:inc-var dbstruct params))
+ ((dec-var) (apply db:dec-var dbstruct params))
((del-var) (apply db:del-var dbstruct params))
+ ((add-var) (apply db:add-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
@@ -227,10 +233,12 @@
;; MISC
((sync-inmem->db) (let ((run-id (car params)))
(db:sync-touched dbstruct run-id force-sync: #t)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
+ ((create-all-triggers) (db:create-all-triggers dbstruct))
+ ((drop-all-triggers) (db:drop-all-triggers dbstruct))
;; TESTMETA
((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
((get-tests-tags) (db:get-tests-tags dbstruct))
@@ -243,11 +251,11 @@
;; NO SYNC DB
((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params))
-
+
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
@@ -292,10 +300,11 @@
((get-run-info) (apply db:get-run-info dbstruct params))
((get-run-status) (apply db:get-run-status dbstruct params))
((get-run-state) (apply db:get-run-state dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((set-run-state-status) (apply db:set-run-state-status dbstruct params))
+ ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
ADDED apimod.scm
Index: apimod.scm
==================================================================
--- /dev/null
+++ apimod.scm
@@ -0,0 +1,37 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit apimod))
+(declare (uses commonmod))
+(declare (uses ulex))
+
+(module apimod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+(import commonmod)
+(import (prefix ulex ulex:))
+
+
+(define (api:execute-requests params)
+ #f)
+
+)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -136,10 +136,11 @@
;; move the getting of archive space down into the below block so that a single run can
;; allocate as needed should a disk fill up
;;
(let* ((blockid-cache (make-hash-table))
(tsname (common:get-testsuite-name))
+ (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
(min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
(arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area
(disk-groups (make-hash-table)) ;;
(test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely
(test-dirs (make-hash-table))
@@ -150,13 +151,16 @@
(if s (string->symbol s) 'bup)))
(archiver-cmd (case archiver
((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
(else #f)))
+ (src-archive-linktree (rmt:get-var "src-archive-linktree"))
(print-prefix "Running: ") ;; change to #f to turn off printing
(preclean-spec (configf:get-section *configdat* "archive-preclean")))
+ (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
+ (rmt:set-var "src-archive-linktree" linktree))
;; (tests:match patt testname itempath)
;; from the test info bin the path to the test by stem
;;
(for-each
@@ -163,12 +167,11 @@
(lambda (test-dat)
(let* ((item-path (db:test-get-item-path test-dat))
(test-name (db:test-get-testname test-dat))
(test-id (db:test-get-id test-dat))
(run-id (db:test-get-run_id test-dat))
- (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
-
+
(toplevel/children (and (db:test-get-is-toplevel test-dat)
(> (rmt:test-toplevel-num-items run-id test-name) 0)))
(test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
;; note the trailing slash to get the dir inspite of it being a link
(test-path (conc linktree "/" test-partial-path))
@@ -185,13 +188,11 @@
partial-path-index)
#f))
;; we need our archive dir checked for every test to enable folks who want to store other ways.
(archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
(archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1))
-
- )
+ (archive-id (if archive-info (car archive-info) -1)))
(if (not archive-dir) ;; no archive disk found, this is fatal
(begin
(debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
min-space " MB space to the [archive-disks] section of megatest.config")
@@ -312,16 +313,131 @@
(for-each
(lambda (test-dat)
(let ((test-id (db:test-get-id test-dat))
(run-id (db:test-get-run_id test-dat)))
(rmt:test-set-archive-block-id run-id test-id archive-id)
- (if (member archive-command '("save-remove"))
- (runs:remove-test-directory test-dat 'archive-remove))))
+ (if (member (symbol->string archive-command) '("save-remove"))
+ (begin
+ (debug:print-info 0 *default-log-port* "remove testdat")
+ (runs:remove-test-directory test-dat 'archive-remove)))))
(hash-table-ref test-groups test-base)))))
(hash-table-keys disk-groups))
#t))
+(define (archive:megatest-db target-patt run-patt)
+ (let* ((blockid-cache (make-hash-table))
+ (tsname (common:get-testsuite-name))
+ (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
+ (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
+ (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
+ (if s (string->symbol s) 'bup)))
+ (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))
+ (print-prefix "Running: ")
+ (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
+ (archive-dir (if archive-info (cdr archive-info) #f))
+ (archive-id (if archive-info (car archive-info) -1))
+ (home-host (common:get-homehost))
+ (archive-time (seconds->std-time-str (current-seconds)))
+ (archive-staging-db (conc *toppath* "/logs/archive_" archive-time))
+ (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
+ (dbfile (conc archive-staging-db "/megatest.db")))
+ (create-directory archive-staging-db #t)
+ (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
+ (if (eq? exit-code 0)
+ (case archiver
+ ((bup) ;; Archive using bup
+ (let* ((bup-init-params (list "-d" archive-dir "init"))
+ (bup-index-params (list "-d" archive-dir "index" archive-staging-db))
+ (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
+ (conc "-" compress) ;; or (conc "--compress=" compress)
+ "-n" (conc tsname "-megatest-db" )
+ (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this?
+ dbfile)))
+ (if (not (common:file-exists? (conc archive-dir "/HEAD")))
+ (begin
+ ;; replace this with jobrunner stuff enventually
+ (debug:print-info 0 *default-log-port* "Init bup in " archive-dir)
+ (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
+ (debug:print-info 0 *default-log-port* "Indexing data to be archived")
+ (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
+ (debug:print-info 0 *default-log-port* "Archiving data with bup")
+ (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (else
+ (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
+ (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))
+
+(define (archive:restore-db archive-path ts)
+ (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
+ (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: #f))
+ (db:multi-db-sync
+ (db:setup #f)
+ 'killservers
+ ;'dejunk
+ ;'adj-testids
+ 'old2new
+ )
+ (debug:print-info 1 *default-log-port* "dropping trigerrs to update linktree")
+ (rmt:drop-all-triggers)
+
+ (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (src-archive-linktree (rmt:get-var "src-archive-linktree")))
+ (if (not (equal? src-archive-linktree linktree))
+ (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
+ (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
+ (rmt:create-all-triggers)
+))
+
+(define (archive:ls->list bup-exe archive-dir internal-path)
+ (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort"))
+ (res '()))
+ (handle-exceptions
+ exn
+ #f ;; anything goes wrong - assume the process in NOT running.
+ (with-input-from-pipe
+ cmd
+ (lambda ()
+ (let* ((inl (read-lines)))
+ (reverse inl)))))))
+
+(define (time-string->seconds tstr ds-flag)
+ (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S")))
+ (vector-set! atime 8 ds-flag)
+ (local-time->seconds atime)))
+
+(define (seconds->std-time-str sec)
+ (time->string
+ (seconds->local-time sec)
+ "%Y-%m-%d-%H%M%S"))
+
+
+(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name run-id test-partial-path test-last-update)
+ (print (seconds->std-time-str test-last-update))
+ (let* ((internal-path (conc testsuite-name "-" run-id))
+ (ts-list (archive:ls->list bup-exe archive-dir internal-path))
+ (ds-flag (vector-ref (seconds->local-time) 8)))
+ (let loop ((hed (car ts-list))
+ (tail (cdr ts-list)))
+ (if (and (null? tail) (equal? hed "latest"))
+ #f
+ (if (and (not (null? tail)) (equal? hed "latest"))
+ (loop (car tail) (cdr tail))
+ (let* ((archive-seconds (time-string->seconds hed ds-flag)))
+ (if (< (abs (- archive-seconds test-last-update)) 120)
+ (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
+ (if (> (length test-list) 0)
+ hed
+ (if (not (null? tail))
+ (loop (car tail) (cdr tail))
+ #f)))
+ (if (null? tail)
+ #f
+ (loop (car tail) (cdr tail))))))))))
+
(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can
;; allocate as needed should a disk fill up
;;
(let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
@@ -351,21 +467,24 @@
(common:real-path test-path)
#f))
(mutex-unlock! rp-mutex)
(new-test-physical-path (conc best-disk "/" test-partial-path))
(archive-block-id (db:test-get-archived test-dat))
+ (test-last-update (db:test-get-last_update 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-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) run-id test-partial-path test-last-update) #f))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/" archive-timestamp-dir "/" 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 (not archive-timestamp-dir)
+ (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
+ (begin
;; 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
(common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
(let* ((base (pathname-directory prev-test-physical-path))
(dirn (pathname-file prev-test-physical-path))
@@ -378,17 +497,14 @@
(begin
;; CREATE WORK AREA
;; test-src-path == #f ==> don't copy in data from tests directory
;; itemdat == string ==> use directly
(create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
-
;; 1. Get the block id from the test info
;; 2. Get the block data given the block id
;; 3. Construct the paths etc. for the following command:
- ;;
;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
-
;; DO BUP RESTORE
(let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
(new-test-path (if (vector? new-test-dat )
(db:test-get-rundir new-test-dat)
(begin
@@ -395,15 +511,16 @@
(debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
(exit 1))))
;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
(bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
(debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
+ (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " "))
;; (mutex-lock! bup-mutex)
(run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
;; (mutex-unlock! bup-mutex)
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
- (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
+ (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))))
(filter vector? tests))))
(define (common:get-youngest-test tests)
(if (null? tests)
#f
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -514,17 +514,19 @@
(debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print-call-chain (current-error-port)) ;;
)
(let* ((fullname (conc "logs/" file))
(mod-time (file-modification-time fullname))
- (file-age (- (current-seconds) mod-time)))
+ (file-age (- (current-seconds) mod-time))
+ (file-old (> file-age (* 48 60 60)))
+ (file-big (> (file-size fullname) 200000)))
(hash-table-set! all-files file mod-time)
(if (or (and (string-match "^.*.log" file)
- (> (file-size fullname) 200000))
+ file-old
+ file-big)
(and (string-match "^server-.*.log" file)
- (> (- (current-seconds) (file-modification-time fullname))
- (* 8 60 60))))
+ file-old))
(let ((gzfile (conc fullname ".gz")))
(if (common:file-exists? gzfile)
(begin
(debug:print-info 0 *default-log-port* "removing " gzfile)
(delete-file* gzfile)
@@ -534,11 +536,12 @@
(system (conc "gzip " fullname))
(inc-stat "gzipped")
(hash-table-set! all-files (conc file ".gz") file-age) ;; add the .gz file and remove the base file
(hash-table-delete! all-files file)
)
- (if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
+ (if (and (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
+ (file-exists? fullname)) ;; just in case it was gzipped - will get it next time
(handle-exceptions
exn
#f
(if (directory? fullname)
(begin
@@ -902,11 +905,16 @@
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
- (cmod:get-testsuite-name *toppath* *configdat*))
+ (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
+ (configf:lookup *configdat* "setup" "testsuite" )
+ (getenv "MT_TESTSUITE_NAME")
+ (if (string? *toppath* )
+ (pathname-file *toppath*)
+ #f))) ;; (pathname-file (current-directory)))))
;; safe getting of toppath
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
@@ -1652,17 +1660,29 @@
))))))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (common:lazy-convert inval)
- (cmod:lazy-convert inval))
+ (let* ((as-num (if (string? inval)(string->number inval) #f)))
+ (or as-num inval)))
;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (common:val->alist val #!key (convert #f))
- (cmod:val->alist val #!key (convert #f)))
+ (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+ (if val-list
+ (map (lambda (x)
+ (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+ (case (length f)
+ ((0) `(,#f)) ;; null string case
+ ((1) `(,(string->symbol (car f))))
+ ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+ (if convert (common:lazy-convert inval) inval))))
+ (else f))))
+ val-list)
+ '())))
;;======================================================================
;; S Y S T E M S T U F F
;;======================================================================
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -34,10 +34,20 @@
;; config file utils
;; misc conversion, data manipulation functions
;; testsuite and area utilites
;;
;;======================================================================
+
+(include "megatest-version.scm")
+(include "megatest-fossil-hash.scm")
+
+(define (get-full-version)
+ (conc megatest-version "-" megatest-fossil-hash))
+
+(define (version-signature)
+ (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
+
;;======================================================================
;; config file utils
;;======================================================================
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -9,11 +9,11 @@
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNnU General Public License for more details.
+;; 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 .
;;======================================================================
@@ -192,12 +192,12 @@
(configf:process-line inl ht allow-processing))
((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") "yes")))
+ (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
(string-substitute "\\s+$" "" res)
res))))))
(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
(filter
@@ -501,10 +501,22 @@
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
+
+(define (configf:lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
;; use to have definitive setting:
;; [foo]
;; var yes
;;
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -44,11 +44,10 @@
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
-(declare (uses megatest-version))
(declare (uses mt))
(declare (uses dbmod))
(import (prefix dbmod dbmod:))
(declare (uses commonmod))
@@ -56,10 +55,11 @@
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
+(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
@@ -3796,10 +3796,11 @@
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 1)
+ ;; may not want this alive (manually merged it from v1.66)
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 2)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -58,10 +58,11 @@
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
+ (stmt-cache (make-hash-table))
) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
@@ -68,10 +69,43 @@
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
+
+;;======================================================================
+;; alist-of-alists
+;;======================================================================
+;;
+;; (define (db:aa-set! dat key1 key2 val)
+;; (let loop ((
+
+;;======================================================================
+;; hash of hashs
+;;======================================================================
+
+
+(define (db:hoh-set! dat key1 key2 val)
+ (let* ((subhash (hash-table-ref/default dat key1 #f)))
+ (if subhash
+ (hash-table-set! subhash key2 val)
+ (begin
+ (hash-table-set! dat key1 (make-hash-table))
+ (db:hoh-set! dat key1 key2 val)))))
+
+(define (db:hoh-get dat key1 key2)
+ (let* ((subhash (hash-table-ref/default dat key1 #f)))
+ (and subhash
+ (hash-table-ref/default subhash key2 #f))))
+
+(define (db:get-cache-stmth dbstruct db stmt)
+ (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
+ (stmth (db:hoh-get stmt-cache db stmt)))
+ (or stmth
+ (let* ((newstmth (sqlite3:prepare db stmt)))
+ (db:hoh-set! stmt-cache db stmt newstmth)
+ newstmth))))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
@@ -415,21 +449,22 @@
(set! *db-last-sync* start-t)
(set! *db-last-access* start-t)
(mutex-unlock! *db-multi-sync-mutex*)
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
-(define (db:safely-close-sqlite3-db db #!key (try-num 3))
+(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
(if (<= try-num 0)
#f
(handle-exceptions
exn
(begin
(thread-sleep! 3)
(sqlite3:interrupt! db)
(db:safely-close-sqlite3-db db try-num: (- try-num 1)))
(if (sqlite3:database? db)
- (begin
+ (let* ((stmts (hash-table-ref/default stmt-cache db #f)))
+ (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
(sqlite3:finalize! db)
#t)
#f))))
;; close all opened run-id dbs
@@ -439,21 +474,20 @@
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain *default-log-port*))
;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
- (let ((tdbs (map db:dbdat-get-db
- (stack->list (dbr:dbstruct-dbstack dbstruct))))
- (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
- (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))))
+ (let ((tdbs (map db:dbdat-get-db
+ (stack->list (dbr:dbstruct-dbstack dbstruct))))
+ (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
+ (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
+ (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
(map (lambda (db)
- (db:safely-close-sqlite3-db db))
-;; (if (sqlite3:database? db)
-;; (sqlite3:finalize! db)))
+ (db:safely-close-sqlite3-db stmt-cache db))
tdbs)
- (db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
- (db:safely-close-sqlite3-db rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ (db:safely-close-sqlite3-db stmt-cache mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
+ (db:safely-close-sqlite3-db stmt-cache rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;; (if (hash-table? locdbs)
;; (for-each (lambda (run-id)
;; (db:close-run-db dbstruct run-id))
@@ -532,10 +566,26 @@
(append (list "runs"
'("id" #f))
(map (lambda (k)(list k #f))
(append keys
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
+ (list "archive_disks"
+ '("id" #f)
+ '("archive_area_name" #f)
+ '("disk_path" #f)
+ '("last_df" #f)
+ '("last_df_time" #f)
+ '("creation_time" #f))
+
+ (list "archive_blocks"
+ '("id" #f)
+ '("archive_disk_id" #f)
+ '("disk_path" #f)
+ '("last_du" #f)
+ '("last_du_time" #f)
+ '("creation_time" #f))
+
(list "test_meta"
'("id" #f)
'("testname" #f)
'("owner" #f)
'("description" #f)
@@ -696,13 +746,14 @@
(member "last_update" fields))
#t) ;; if given a number, just use it for all fields
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
- (map car fields))) #t)
+ (map car fields)))
+ #t)
(last-update
- (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
+ (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
#f)
(else
#f)))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
(if (number? last-update)
@@ -728,11 +779,11 @@
(fromdats '())
(totrecords 0)
(batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
(todat (make-hash-table))
(count 0)
-
+ (field-names (map car fields))
(delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
)
;; set up the field->num table
(for-each
@@ -775,12 +826,19 @@
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(let* ((db (db:dbdat-get-db targdb))
+ (drp-trigger (if (member "last_update" field-names)
+ (db:drop-trigger db tablename)
+ #f))
+ (is-trigger-dropped (if (member "last_update" field-names)
+ (db:is-trigger-dropped db tablename) #f))
(stmth (sqlite3:prepare db full-ins)))
(db:delay-if-busy targdb) ;; NO WAITING
+ (if (member "last_update" field-names)
+ (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped))
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db
(lambda ()
@@ -798,14 +856,15 @@
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
- fromdat-lst))
- ))
+ fromdat-lst))))
fromdats)
- (sqlite3:finalize! stmth)))
+ (sqlite3:finalize! stmth)
+ (if (member "last_update" field-names)
+ (db:create-trigger db tablename))))
(append (list todb) slave-dbs))))
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (or (debug:debug-mode 12)
(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
@@ -1156,10 +1215,95 @@
;; (define open-run-close
#;(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
+
+(define db:trigger-list
+ (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ FOR EACH ROW
+ BEGIN
+ UPDATE runs SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ FOR EACH ROW
+ BEGIN
+ UPDATE run_stats SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ FOR EACH ROW
+ BEGIN
+ UPDATE tests SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_steps SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_data SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )))
+
+(define (db:create-all-triggers dbstruct)
+(db:with-db
+ dbstruct #f #f
+ (lambda (db)
+(db:create-triggers db))))
+
+(define (db:create-triggers db)
+ (for-each (lambda (key)
+ (sqlite3:execute db (cadr key)))
+ db:trigger-list))
+
+(define (db:drop-all-triggers dbstruct)
+(db:with-db
+ dbstruct #f #f
+ (lambda (db)
+(db:drop-triggers db))))
+
+(define (db:is-trigger-dropped db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (sqlite3:for-each-row
+ (lambda (name)
+ ;(print name)
+ (set! res (vector name)))
+ db
+ "select name from sqlite_master where type = 'trigger' ;"
+ )))
+
+(define (db:drop-triggers db)
+ (for-each (lambda (key)
+ (sqlite3:execute db (conc "drop trigger " (car key))))
+ db:trigger-list))
+
+(define (db:drop-trigger db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (conc "drop trigger " trigger-name))))
+ db:trigger-list)))
+
+(define (db:create-trigger db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (cadr key))))
+ db:trigger-list)))
+
(define (db:initialize-main-db dbdat)
(when (not *configinfo*)
(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
@@ -1201,29 +1345,31 @@
comment TEXT DEFAULT '',
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
- FOR EACH ROW
- BEGIN
- UPDATE runs SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE runs SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
id INTEGER PRIMARY KEY,
run_id INTEGER,
state TEXT,
status TEXT,
count INTEGER,
last_update INTEGER DEFAULT (strftime('%s','now')))")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
- FOR EACH ROW
- BEGIN
- UPDATE run_stats SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE run_stats SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
@@ -1319,17 +1465,18 @@
;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
-
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
- FOR EACH ROW
- BEGIN
- UPDATE tests SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE tests SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
(id INTEGER PRIMARY KEY,
test_id INTEGER,
stepname TEXT,
state TEXT DEFAULT 'NOT_STARTED',
@@ -1338,16 +1485,17 @@
comment TEXT DEFAULT '',
logfile TEXT DEFAULT '',
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
- FOR EACH ROW
- BEGIN
- UPDATE test_steps SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE test_steps SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
@@ -1358,16 +1506,17 @@
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
- FOR EACH ROW
- BEGIN
- UPDATE test_data SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE test_data SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
id INTEGER PRIMARY KEY,
test_id INTEGER,
update_time TIMESTAMP,
cpuload INTEGER DEFAULT -1,
@@ -1380,10 +1529,12 @@
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
+ (print "creating trigges from init")
+ (db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
;;======================================================================
@@ -1607,35 +1758,22 @@
(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)
-
-
(define (db:get-status-from-final-status-file run-dir)
- (let (
- (infile (conc run-dir "/.final-status")))
-
- ;; first verify we are able to write the output file
- (if (not (file-read-access? infile))
- (begin
- (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
+ (let ((infile (conc run-dir "/.final-status")))
+ ;; first verify we are able to write the output file
+ (if (not (file-read-access? infile))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
(debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
#f
)
- (with-input-from-file infile read-lines)
- )
- )
-)
-
-
-
+ (with-input-from-file infile read-lines)
+ )))
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
@@ -1754,10 +1892,12 @@
(debug:print 0 *default-log-port* "INFO: test " test-id " on host " host " has a process on pid " pid ", NOT setting to DEAD.")
(begin
(debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result)
(db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD"
"Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
+ ;; call end of eud of run detection for posthook - from merge, is it needed?
+ ;; (launch:end-of-run-check run-id)
all-ids)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)
)))))))
@@ -1952,10 +2092,20 @@
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
+(define (db:inc-var dbstruct var)
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
+
+(define (db:dec-var dbstruct var)
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
+
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
@@ -1969,10 +2119,15 @@
(define (db:set-var dbstruct var val)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
+(define (db:add-var dbstruct var val)
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
+
(define (db:del-var dbstruct var)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
@@ -2854,23 +3009,27 @@
(if limit (conc " LIMIT " limit) " ")
(if offset (conc " OFFSET " offset) " ")
";"
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
- (db:with-db dbstruct run-id #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
- )))
- (case qryvals
- ((shortlist)(map db:test-short-record->norm res))
- ((#f) res)
- (else res))))
+ (let* ((res (db:with-db dbstruct run-id #f
+ (lambda (db)
+ ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res . row)
+ ;; id run-id testname state status event-time host cpuload
+ ;; diskfree uname rundir item-path run-duration final-logf comment)
+ (cons (list->vector row) res))
+ '()
+ db qry ;; stmth
+ (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
+ ))))))
+ (case qryvals
+ ((shortlist)(map db:test-short-record->norm res))
+ ((#f) res)
+ (else res)))))
(define (db:test-short-record->norm inrec)
;; "id,run_id,testname,item_path,state,status"
;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(vector (vector-ref inrec 0) ;; id
@@ -2880,26 +3039,38 @@
(vector-ref inrec 5) ;; status
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
-#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
- (let* ((res '())
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
- (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
- (db:with-db dbstruct run-id #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
- db
- qry
- run-id)))
- res))
+;;
+;; 1. cache tests-match-qry
+;; 2. compile qry and store in hash
+;; 3. convert for-each-row to fold
+;;
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (db)
+ (let* ((res '())
+ (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
+ (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt)))
+ (or sh
+ (let* ((tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
+ (newsh (sqlite3:prepare db qry)))
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+ (db:hoh-set! stmt-cache db testpatt newsh)
+ newsh)))))
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))
+ '()
+ stmth
+ run-id))))))
(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
(let* ((res '())
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
@@ -3040,23 +3211,21 @@
test-id))))))
(mt:process-triggers dbstruct run-id test-id newstate newstatus))
;; NEW BEHAVIOR: Count tests running in all runs!
;;
-(define (db:get-count-tests-running dbstruct run-id)
+(define (db:get-count-tests-running dbstruct run-id fastmode)
+ (let* ((qry (if fastmode
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")))
(db:with-db
dbstruct
run-id
#f
(lambda (db)
- (sqlite3:first-result
- db
- ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
- ;; AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted')
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"
- ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"
- ))))
+ (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
+ (sqlite3:first-result stmth))))))
;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
(db:with-db
@@ -3072,19 +3241,21 @@
run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
;; NEW BEHAVIOR: Look only at single run with run-id
;;
;; (define (db:get-running-stats dbstruct run-id)
-(define (db:get-count-tests-running-for-run-id dbstruct run-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (sqlite3:first-result
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id))))
+(define (db:get-count-tests-running-for-run-id dbstruct run-id fastmode)
+ (let* ((qry (if fastmode
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")))
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (db)
+ (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
+ (sqlite3:first-result stmth run-id))))))
;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
@@ -3091,14 +3262,14 @@
(db:with-db
dbstruct
run-id
#f
(lambda (db)
- (sqlite3:first-result
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname))))
-
+ (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
+ (stmth (db:get-cache-stmth dbstruct db stmt)))
+ (sqlite3:first-result
+ stmth run-id testname)))))
(define (db:get-not-completed-cnt dbstruct run-id)
(db:with-db
dbstruct
run-id
@@ -3209,10 +3380,16 @@
#f
(loop (car tal)(cdr tal)(+ indx 1)))))))
(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
+(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
+ old-lt new-lt old-lt new-lt))))
;; NOTE: Use db:test-get* to access records
;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
(define (db:get-all-tests-info-by-run-id dbstruct run-id)
(let* ((res '()))
@@ -3466,25 +3643,25 @@
;;======================================================================
;; T E S T D A T A
;;======================================================================
- (define (db:get-data-info-by-id dbstruct test-data-id)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f #f)))
- (sqlite3:for-each-row
- (lambda (id test-id category variable value expected tol units comment status type last-update)
- (set! res (vector id test-id category variable value expected tol units comment status type last-update)))
- db
- "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-data-id)
- res))))
-
+(define (db:get-data-info-by-id dbstruct test-data-id)
+ (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (db)
+ (let* ((stmth (db:get-cache-stmth dbstruct db stmt))
+ (res (sqlite3:fold-row
+ (lambda (res id test-id category variable value expected tol units comment status type last-update)
+ (vector id test-id category variable value expected tol units comment status type last-update))
+ (vector #f #f #f #f #f #f #f #f #f #f #f #f)
+ stmth
+ test-data-id)))
+ res)))))
;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field,
;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
@@ -3929,10 +4106,13 @@
run-id )))))
test-count-recs))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
+;;
+;; NOTE: This is called within a transaction
+;;
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info dbstruct run-id test-name item-path))
(item-state (or item-state-in (db:test-get-state test-info)))
(item-status (or item-status-in (db:test-get-status test-info)))
(other-items-count-recs (db:with-db
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -25,15 +25,15 @@
(import canvas-draw-iup)
(use regex typed-records matchable)
(declare (unit dcommon))
-(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))
+(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
@@ -637,11 +637,11 @@
(iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
(iup:attribute-set! stats-matrix "NUMCOL" max-col )
(iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
(iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
(iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
- (print "row-indices: " row-indices " col-indices: " col-indices)
+ ;;(print "row-indices: " row-indices " col-indices: " col-indices)
;; Row labels
(for-each (lambda (ind)
(let* ((name (car ind))
(num (cadr ind))
(key (conc num ":0")))
Index: docs/manual/installation.txt
==================================================================
--- docs/manual/installation.txt
+++ docs/manual/installation.txt
@@ -20,10 +20,14 @@
Dependencies
~~~~~~~~~~~~
Chicken scheme and a number of "eggs" are required for building
+Megatest. See the script installall.sh in the utils directory of the
+source distribution for an automated way to install everything
+needed for building Megatest on Linux.
+
Megatest. In the v1.66 and beyond assistance to create the build
system is built into the Makefile.
.Installation steps (overview)
-------------------------------------
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
-
+
The Megatest Users Manual