Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -26,78 +26,45 @@
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
-SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
- server.scm configf.scm db.scm keys.scm \
- process.scm runs.scm tests.scm genexample.scm \
- tdb.scm mt.scm \
- ezsteps.scm api.scm \
- subrun.scm archive.scm env.scm \
- diff-report.scm
-
-# cgisetup/models/pgdb.scm
+SRCFILES = server.scm \
+ env.scm
+
+pgdb.scm : cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
configfmod.scm processmod.scm servermod.scm megatestmod.scm \
stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \
pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \
subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \
- ezstepsmod.scm
+ ezstepsmod.scm mtbody.scm envmod.scm genexample.scm mutils.scm \
+ diff-report.scm tdb.scm vgmod.scm dcommon.scm
transport-mode.scm : transport-mode.scm.template
cp transport-mode.scm.template transport-mode.scm
dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm
-mtest : transport-mode.scm
-dboard : dashboard-transport-mode.scm
-
-# dbmod.import.o is just a hack here
-
-process.o : mofiles/processmod.o
-mofiles/configfmod.o : mofiles/processmod.o
-mofiles/processmod.o : mofiles/commonmod.o
-mofiles/servermod.o : mofiles/commonmod.o
-mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o
-mofiles/dbmod.o : mofiles/mtmod.o
-# mofiles/mtmod.o : mofiles/tcp-transportmod.o
-mofiles/megatestmod.o : mofiles/pkts.o mofiles/servermod.o mofiles/fsmod.o
-# mofiles/mtmod.o : mofiles/testsmod.o
-mofiles/subrunmod.o : mofiles/tasksmod.o
-mofiles/launchmod.o : mofiles/subrunmod.o mofiles/runsmod.o
-mofiles/launchmod.o : mofiles/ezstepsmod.o
-mofiles/runsmod.o : mofiles/archivemod.o
-mofiles/testsmod.o : mofiles/dbmod.o
-
-mofiles/dbfile.o : \
- mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o
-mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o
-mofiles/dbmod.o : mofiles/dbfile.o
-mofiles/api.o : mofiles/apimod.o
-mofiles/commonmod.o : mofiles/debugprint.o mofiles/stml2.o
-configf.o : commonmod.import.o
-mofiles/dbfile.o : mofiles/debugprint.o
-mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o
-db.o : mofiles/dbmod.o mofiles/dbfile.o
-mofiles/debugprint.o : mofiles/mtargs.o
-mofiles/tcp-transportmod.o : mofiles/portlogger.o
-mofiles/tasksmod.o : mofiles/rmtmod.o mofiles/pgdb.o
-mofiles/fsmod.o : mofiles/debugprint.o
-
-# 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 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
+# mtest : transport-mode.scm unitdeps.pdf
+# dboard : dashboard-transport-mode.scm
+
+# include the generated dependencies
+include make.inc
+
+make.inc : megatest-fossil-hash.scm
+mofiles/mtargs.o mofiles/cookie.o : make.inc
+megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)
+
+# special cases due to source files not in current directory
+mofiles/pgdb.o : mofiles/configfmod.o mofiles/mtargs.o mofiles/debugprint.o
+
+GUISRCF = dashboard-guimonitor.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
@@ -105,17 +72,10 @@
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
%.import.o : %.import.scm
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
-# 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 mofiles -I $* -J -c $< -o $*.o
-# cp $*.o mofiles/$*.o
-# @touch $*.import.scm # ensure it is touched after the .o is made
-
%.import.scm mofiles/%.o : %.scm
@mkdir -p mofiles
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
@if [[ -e $*.import.scm ]];then touch $*.import.scm;fi # ensure it is touched after the .o is made
@@ -126,66 +86,26 @@
ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif
-# CSIPATH=$(shell which csi)
-# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
-# ARCHSTR=$(shell uname -m)_$(shell uname -r)
-# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
-# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell 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)
-
-mtest: $(OFILES) readline-fix.scm $(MOFILES) $(MOIMPFILES) megatest.o megatest-version.scm
+mtest: $(OFILES) readline-fix.scm $(MOFILES) $(MOIMPFILES) megatest.o megatest-version.scm transport-mode.scm unitdeps.pdf
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm dashboard-transport-mode.scm
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
mtut: $(OFILES) $(MOFILES) $(MOIMPFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) mtut.scm -o mtut
-# include makefile.inc
-
-# TCMTOBJS = \
-# api.o \
-# archive.o \
-# cgisetup/models/pgdb.o \
-# common.o \
-# configf.o \
-# db.o \
-# env.o \
-# items.o \
-# keys.o \
-# launch.o \
-# margs.o \
-# mt.o \
-# ods.o \
-# process.o \
-# rmt.o \
-# runconfig.o \
-# runs.o \
-# server.o \
-# tasks.o \
-# tdb.o \
-# tests.o \
-# subrun.o \
-# ezsteps.o
-#
-# # mofiles/rmtmod.o \
-# # mofiles/commonmod.o \
-#
-# tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)
-# csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
-
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
mkdir -p $(PREFIX)/share/docs
@@ -202,68 +122,10 @@
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
-mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm
-common.o : mofiles/commonmod.o
-mofiles/configfmod.o : mofiles/commonmod.o
-
-# mofiles/dbmod.o : mofiles/configfmod.o
-
-# 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 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
-db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
-
-tests.o tasks.o dashboard-tasks.o : task_records.scm
-
-runs.o : test_records.scm
-
-# mofiles-made : $(MOFILES)
-# make $(MOIMPFILES)
-# touch mofiles-made
-
-megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)
-
-rmt.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.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 megatest-version.scm
-
-common_records.scm : altdb.scm
-
-mofiles/dbfile.o : mofiles/commonmod.o
-
-# mofiles/stml2.o : mofiles/cookie.o
-# configf.o : mofiles/commonmod.o
-
-vg.o dashboard.o : vg_records.scm megatest-version.scm
-
-dcommon.o : run_records.scm
-
-mofiles/stml2.o : mofiles/cookie.o
-
-# # 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/mutils.o : mutils/mutils.scm
-# mofiles/cookie.o : stml2/cookie.scm
-# mofiles/stml2.o : stml2/stml2.scm
-
-# Temporary while transitioning to new routine
-# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
-
-# for the modularized stuff
-mofiles/rmtmod.o : mofiles/commonmod.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
$(OFILES) $(GOFILES) : common_records.scm
@@ -450,68 +312,10 @@
tcmt ftail.import.scm readline-fix.scm serialize-env \
dboard dboard.o megatest.o dashboard.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
rm -rf share
-#======================================================================
-# Make the records files
-#======================================================================
-
-# vg_records.scm : records.sh
-# ./records.sh
-
-#======================================================================
-# Deploy section (not complete yet)
-#======================================================================
-
-$(DEPLOYHELPERS) : utils/mt_*
- $(INSTALL) $< $@
- chmod a+X $@
-
-deploytarg/apropos.so : Makefile
- chicken-install -p deploytarg -deploy -keep-installed $(EGGS)
-
-deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so
-
-# puts deployed megatest in directory "megatest"
-deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so
- csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
- mv deploytarg/deploytarg deploytarg/mtest
-
-deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
- csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
- mv deploytarg/deploytarg deploytarg/dboard
-
-datashare-testing/sd : datashare.scm $(OFILES)
- csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd
-
-datashare-testing/sdat: sharedat.scm $(OFILES)
- csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat
-
-sd : datashare-testing/sd
- mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath
-
-xterm : sd
- (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)
-
-datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish
-
-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) 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
- rm datashare-testing/spublish
-
-sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish
readline-fix.scm :
if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
echo "(define *use-new-readline* #f)" > readline-fix.scm; \
else \
@@ -532,20 +336,26 @@
fi
if csi -ne '(import postgresql)'&> /dev/null;then \
echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
-# csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o sync-hash.o tasks.o tdb.o tests.o tree.o
-
-unitdeps.dot : *scm ./utils/plot-uses Makefile
- ./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot
+DOTIGNORES= processmod.import,dbfile.import,dbmod.import,configfmod.import,mtmod.import,processmod.import,commonmod.import,mtargs.import
+unitdeps.dot make.inc : *mod.scm ./utils/plot-uses Makefile
+ ./utils/plot-uses todot $(DOTIGNORES) $$(ls *.scm|grep -v import) > unitdeps.dot
# ./utils/plot-uses todot commonmod,portlogger,stml2,debugprint,mtargs apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm mtmod.scm processmod.scm rmtmod.scm servermod.scm tcp-transportmod.scm > uses.dot ; dot uses.dot -Tpdf -o uses.pdf
+# apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm mtmod.scm processmod.scm rmtmod.scm servermod.scm tcp-transportmod.scm testsmod.scm
+
+uses.pdf : *scm utils/plot-uses Makefile
+ ./utils/plot-uses todot portlogger,stml2,debugprint,mtargs *mod.scm launch.scm > uses-in.dot
+ tred uses-in.dot > uses.dot
+ dot uses.dot -Tpdf -o uses.pdf
+
unitdeps.pdf : unitdeps.dot
- dot unitdeps.dot -Tpdf -o unitdeps.pdf
+ tred unitdeps.dot > unitdeps-tred.dot
+ dot unitdeps-tred.dot -Tpdf -o unitdeps.pdf
./utils/plot-uses : utils/plot-uses.scm
csc utils/plot-uses.scm
# create a pdf dot graphviz diagram from notations in rmt.scm
DELETED api.scm
Index: api.scm
==================================================================
--- api.scm
+++ /dev/null
@@ -1,130 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, 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 api))
-(declare (uses db))
-(declare (uses apimod))
-
-(declare (uses debugprint))
-(declare (uses commonmod))
-(declare (uses dbmod))
-(declare (uses dbfile))
-(declare (uses tcp-transportmod))
-
-(import commonmod)
-(import apimod)
-(import dbmod)
-(import dbfile)
-(import debugprint)
-(import tcp-transportmod)
-
-(use srfi-69
- srfi-18
- posix
- matchable
- s11n
- typed-records)
-
-
-;; QUEUE METHOD
-
-(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params)
- (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request))
-
-
-;; indat is (cmd run-id params meta)
-;;
-;; WARNING: Do not print anything in the lambda of this function as it
-;; reads/writes to current in/out port
-;;
-(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params)
- (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
- (if (not *server-signature*)
- (set! *server-signature* (tt:mk-signature *toppath*)))
- (lambda (indat)
- (api:register-thread (current-thread))
- (let* ((result
- (let* ((numthreads (api:get-count-threads-alive))
- (delay-wait (if (> numthreads 10)
- (- numthreads 10)
- 0))
- (normal-proc (lambda (cmd run-id params)
- (case cmd
- ((ping) *server-signature*)
- (else
- (api:dispatch-request dbstruct cmd run-id params))))))
- (set! *api-process-request-count* numthreads)
- (set! *db-last-access* (current-seconds))
-;; (if (not (eq? numthreads numthreads))
-;; (begin
-;; (api:remove-dead-or-terminated)
-;; (let ((threads-now (api:get-count-threads-alive)))
-;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
-;; (set! numthreads threads-now))))
- (match indat
- ((cmd run-id params meta)
- (let* ((start-t (current-milliseconds))
- (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
- (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
- (case cmd
- ((ping) #t) ;; we are fine
- (else
- (assert ok "FATAL: database file and run-id not aligned.")))))
- (ttdat *server-info*)
- (server-state (tt-state ttdat))
- (maxthreads 20) ;; make this a parameter?
- (status (cond
- ((and (> numthreads maxthreads)
- (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
- 'busy)
- ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
- (else 'ok)))
- (errmsg (case status
- ((busy) (conc "Server overloaded, "numthreads" threads in flight"))
- ((loaded) (conc "Server loaded, "numthreads" threads in flight"))
- (else #f)))
- (result (case status
- ((busy)
- (if (eq? cmd 'ping)
- (normal-proc cmd run-id params)
- ;; numthreads must be greater than 5 for busy
- (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay
- )) ;; (- numthreads 29)) ;; call back in as many seconds
- ((loaded)
- (normal-proc cmd run-id params))
- (else
- (normal-proc cmd run-id params))))
- (meta (case cmd
- ((ping) `((sstate . ,server-state)))
- (else `((wait . ,delay-wait)))))
- (payload (list status errmsg result meta)))
- ;; (cmd run-id params meta)
- (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
- payload))
- (else
- (assert #f "FATAL: failed to deserialize indat "indat))))))
- ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; (serialize payload)
-
- (api:unregister-thread (current-thread))
- result)))
-
-(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new
-
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -25,11 +25,20 @@
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))
(module apimod
- *
+ (
+ *server-signature*
+ api:tcp-dispatch-request-make-handler-core
+ api:register-thread
+ api:unregister-thread
+ api:get-count-threads-alive
+ api:print-db-stats
+ api:queue-processor
+ api:dispatch-request
+ )
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)
@@ -311,15 +320,19 @@
((cmd run-id params meta)
(let* ((start-t (current-milliseconds))
;; factor this out and move before this let, it is just
;; an assert if not ping and dbfname is not correct
(db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
- (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
+ (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct)))
+ (message ""))
(case cmd
((ping) #t) ;; we are fine
(else
- (assert ok "FATAL: database file and run-id not aligned.")))))
+ (begin
+ (set! message (conc "tcp request handler: dbstruct database file " (dbr:dbstruct-dbfname dbstruct) " not aligned with run-id " run-id))
+ (assert ok message)))))
+ )
(ttdat *server-info*)
(server-state (tt-state ttdat))
(status 'ok) ;; anything legit we can do with status?
(delay-wait 0)
(result (if (eq? cmd 'ping)
DELETED archive.scm
Index: archive.scm
==================================================================
--- archive.scm
+++ /dev/null
@@ -1,38 +0,0 @@
-;; Copyright 2006-2014, 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 .
-;;
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(declare (unit archive))
-(declare (uses db))
-(declare (uses debugprint))
-(declare (uses mtargs))
-(declare (uses common))
-(declare (uses commonmod))
-(declare (uses configfmod))
-(declare (uses rmtmod))
-
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69
- format md5 message-digest srfi-18)
-
-(import commonmod
- configfmod
- debugprint
- rmtmod
- (prefix mtargs args:))
-
Index: archivemod.scm
==================================================================
--- archivemod.scm
+++ archivemod.scm
@@ -33,15 +33,24 @@
(declare (uses fsmod))
(declare (uses processmod))
(declare (uses mtmod))
(declare (uses dbmod))
(declare (uses dbfile))
+(declare (uses rmtmod))
(use srfi-69)
(module archivemod
- *
+ (
+ archive:get-archive-disks
+ archive:allocate-new-archive-block
+ archive:get-timestamp-dir
+ archive:megatest-db
+ archive:bup-get-data
+ archive:restore-db
+
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -121,12 +130,12 @@
srfi-69
typed-records
z3
)
-(include "common_records.scm")
-(include "db_records.scm")
+;; (include "common_records.scm")
+;; (include "db_records.scm")
;;======================================================================
;;
;;======================================================================
@@ -236,17 +245,17 @@
(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 #f) ;; FIXME! (server:choose-server *toppath* 'homehost))
+ (home-host (get-host-name)) ;; FIXME! (server:choose-server *toppath* 'homehost))
(archive-time (seconds->std-time-str (current-seconds)))
(archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
(tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/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)))
+ (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc 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))
ADDED attic/codescanlib.scm
Index: attic/codescanlib.scm
==================================================================
--- /dev/null
+++ attic/codescanlib.scm
@@ -0,0 +1,144 @@
+;; 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 .
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
+(define (load-scm-file scm-file)
+ ;;(print "load "scm-file)
+ (handle-exceptions
+ exn
+ '()
+ (with-input-from-string
+ (conc "("
+ (with-input-from-file scm-file read-all)
+ ")" )
+ read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;; -- be advised:
+;; * this may be fooled by macros, since this code does not take them into account.
+;; * this code does only checks for form (define ( ... ) )
+;; so it excludes from reckoning
+;; - generated functions, as in things like foo-set! from defstructs,
+;; - define-inline, (
+;; - define procname (lambda ..
+;; - etc...
+(define (get-toplevel-procs+file+args+body filename)
+ (let* ((scm-tree (load-scm-file filename))
+ (procs
+ (filter identity
+ (map
+ (match-lambda
+ [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+ [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+ [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+ [('define (defname args ...) body ...) ;; match (define (procname ) )
+ (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+ (list defname filename args body)
+ #f)]
+ [else #f] ) scm-tree))))
+ procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+ (cond
+ ((null? body) '())
+ ((atom? body) (list body))
+ (else
+ (apply append (map get-atoms-in-body body)))))
+
+;; given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+ (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+ (res
+ (map
+ (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (args (caddr item))
+ (body (cadddr item))
+ (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+ (list proc file atoms)))
+ toplevel-proc-items)))
+ res))
+
+;; uniquify a list of atoms
+(define (unique-atoms lst)
+ (let loop ((lst (flatten lst)) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((c (car lst)))
+ (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+ (let* ((all-procs (map car all-procs+file+calls))
+ (caller-ht (make-hash-table)))
+ ;; let's cross reference with a hash table
+ (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+ (for-each (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (calls (caddr item)))
+ (for-each (lambda (callee)
+ (hash-table-set! caller-ht callee
+ (cons proc
+ (hash-table-ref caller-ht callee))))
+ calls)))
+ all-procs+file+calls)
+ (map (lambda (x)
+ (let ((k (car x))
+ (r (unique-atoms (cdr x))))
+ (cons k r)))
+ (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+ (let* ((all-procs+file+atoms
+ (apply append (map get-procs+file+atoms all-scm-files)))
+ (all-procs (map car all-procs+file+atoms))
+ (all-procs+file+calls ; proc calls things in calls list
+ (map (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (atoms (caddr item))
+ (calls
+ (filter identity
+ (map
+ (lambda (x)
+ (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
+ (member x all-procs))
+ x
+ #f))
+ atoms))))
+ (list proc file calls)))
+ all-procs+file+atoms))
+ (callers (get-callers-alist all-procs+file+calls)))
+ callers))
DELETED codescanlib.scm
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;; 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 .
-;;
-
-;; gotta compile with csc, doesn't work with csi -s for whatever reason
-
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
-
-;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
-(define (load-scm-file scm-file)
- ;;(print "load "scm-file)
- (handle-exceptions
- exn
- '()
- (with-input-from-string
- (conc "("
- (with-input-from-file scm-file read-all)
- ")" )
- read)))
-
-;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
-;; -- be advised:
-;; * this may be fooled by macros, since this code does not take them into account.
-;; * this code does only checks for form (define ( ... ) )
-;; so it excludes from reckoning
-;; - generated functions, as in things like foo-set! from defstructs,
-;; - define-inline, (
-;; - define procname (lambda ..
-;; - etc...
-(define (get-toplevel-procs+file+args+body filename)
- (let* ((scm-tree (load-scm-file filename))
- (procs
- (filter identity
- (map
- (match-lambda
- [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
- [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
- [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
- [('define (defname args ...) body ...) ;; match (define (procname ) )
- (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
- (list defname filename args body)
- #f)]
- [else #f] ) scm-tree))))
- procs))
-
-
-;; given a sexp, return a flat list of atoms in that sexp
-(define (get-atoms-in-body body)
- (cond
- ((null? body) '())
- ((atom? body) (list body))
- (else
- (apply append (map get-atoms-in-body body)))))
-
-;; given a file, return a list of procname, file, list of atoms in said procname
-(define (get-procs+file+atoms file)
- (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
- (res
- (map
- (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (args (caddr item))
- (body (cadddr item))
- (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
- (list proc file atoms)))
- toplevel-proc-items)))
- res))
-
-;; uniquify a list of atoms
-(define (unique-atoms lst)
- (let loop ((lst (flatten lst)) (res '()))
- (if (null? lst)
- (reverse res)
- (let ((c (car lst)))
- (loop (cdr lst) (if (member c res) res (cons c res)))))))
-
-;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
-;; returning alist mapping procname to procname that calls said procname
-(define (get-callers-alist all-procs+file+calls)
- (let* ((all-procs (map car all-procs+file+calls))
- (caller-ht (make-hash-table)))
- ;; let's cross reference with a hash table
- (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
- (for-each (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (calls (caddr item)))
- (for-each (lambda (callee)
- (hash-table-set! caller-ht callee
- (cons proc
- (hash-table-ref caller-ht callee))))
- calls)))
- all-procs+file+calls)
- (map (lambda (x)
- (let ((k (car x))
- (r (unique-atoms (cdr x))))
- (cons k r)))
- (hash-table->alist caller-ht))))
-
-;; create a handy cross-reference of callees to callers in the form of an alist.
-(define (get-xref all-scm-files)
- (let* ((all-procs+file+atoms
- (apply append (map get-procs+file+atoms all-scm-files)))
- (all-procs (map car all-procs+file+atoms))
- (all-procs+file+calls ; proc calls things in calls list
- (map (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (atoms (caddr item))
- (calls
- (filter identity
- (map
- (lambda (x)
- (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
- (member x all-procs))
- x
- #f))
- atoms))))
- (list proc file calls)))
- all-procs+file+atoms))
- (callers (get-callers-alist all-procs+file+calls)))
- callers))
DELETED common.scm
Index: common.scm
==================================================================
--- common.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 common))
-(declare (uses commonmod))
-(declare (uses processmod))
-(declare (uses configfmod))
-(declare (uses rmtmod))
-(declare (uses debugprint))
-(declare (uses mtargs))
-
-
-(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
- format dot-locking csv-xml z3 udp ;; sql-de-lite
- hostinfo md5 message-digest typed-records directory-utils stack
- matchable regex posix (srfi 18) extras ;; tcp
- (prefix nanomsg nmsg:)
- (prefix sqlite3 sqlite3:)
- pkts (prefix dbi dbi:)
- )
-(use posix-extras pathname-expand files)
-
-
-(import commonmod
- processmod
- debugprint
- configfmod
- rmtmod
- (prefix mtargs args:))
-
-(include "common_records.scm")
-
-
-
-
-
-;;======================================================================
-;; (define *common:telemetry-log-state* 'startup)
-;; (define *common:telemetry-log-socket* #f)
-;;
-;; (define (common:telemetry-log-open)
-;; (if (eq? *common:telemetry-log-state* 'startup)
-;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
-;; (serverport (configf:lookup-number *configdat* "telemetry" "port"))
-;; (user (or (get-environment-variable "USER") "unknown"))
-;; (host (or (get-environment-variable "HOST") "unknown")))
-;; (set! *common:telemetry-log-state*
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
-;; 'broken)
-;; (if (and serverhost serverport user host)
-;; (let* ((s (udp-open-socket)))
-;; ;;(udp-bind! s #f 0)
-;; (udp-connect! s serverhost serverport)
-;; (set! *common:telemetry-log-socket* s)
-;; 'open)
-;; 'not-needed))))))
-;;
-;; (define (common:telemetry-log event #!key (payload '()))
-;; (if (eq? *common:telemetry-log-state* 'startup)
-;; (common:telemetry-log-open))
-;;
-;; (if (eq? 'open *common:telemetry-log-state*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)")
-;; ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose)
-;; ;;(common:telemetry-log-close)
-;; (define *common:telemetry-log-state* 'broken-or-no-server)
-;; (set! *common:telemetry-log-socket* #f)
-;; )
-;; (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events
-;; (let* ((user (or (get-environment-variable "USER") "unknown"))
-;; (host (or (get-environment-variable "HOST") "unknown"))
-;; (start (conc "[megatest "event"]"))
-;; (toppath (or *toppath* "/dev/null"))
-;; (payload-serialized
-;; (base64:base64-encode
-;; (z3:encode-buffer
-;; (with-output-to-string (lambda () (pp payload))))))
-;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
-;; toppath":"payload-serialized)))
-;; (udp-send *common:telemetry-log-socket* msg))))))
-;;
-;; (define (common:telemetry-log-close)
-;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (define *common:telemetry-log-state* 'closed-fail)
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
-;; )
-;; (begin
-;; (define *common:telemetry-log-state* 'closed)
-;; (udp-close-socket *common:telemetry-log-socket*)
-;; (set! *common:telemetry-log-socket* #f)))))
-
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -50,12 +50,254 @@
(import stml2
)
(module commonmod
- *
+ (
+ ;; globals
+ *already-seen-runconfig-info*
+ *common:badly-ended-states*
+ *common:dont-roll-up-states*
+ *common:ended-states*
+ *common:not-started-ok-statuses*
+ *common:running-states*
+ *common:std-states*
+ *common:std-statuses*
+ *common:well-ended-states*
+ *configdat*
+ *configinfo*
+ *configstatus*
+ *db-access-allowed*
+ *db-api-call-time*
+ *db-cache-path*
+ *db-keys*
+ *default-area-tag*
+ *env-vars-by-run-id*
+ *globalexitstatus*
+ *host-loads*
+ *keyvals*
+ *last-launch*
+ *launch-setup-mutex*
+ *logged-in-clients*
+ *my-client-signature*
+ *on-exit-procs*
+ *passnum*
+ *pkts-info*
+ *pre-reqs-met-cache*
+ *runconfigdat*
+ *runremote*
+ *server-id*
+ *server-info*
+ *target*
+ *task-db*
+ *test-meta-updated*
+ *testconfigs*
+ *time-to-exit*
+ *toppath*
+ *toptest-paths*
+ *transport-type*
+ *common:this-exe-dir*
+
+ common:list-is-sublist
+ seconds->year-week/day-time
+ common:find-start-mark-and-mark-delta
+
+ common:with-orig-env
+ alist->env-vars
+ any->number
+ any->number-if-possible
+ assoc/default
+ client:get-signature
+
+ common:alist-ref/default
+ common:clear-caches
+ common:dir-clean-up
+ common:directory-exists?
+ common:directory-writable?
+ common:fail-safe
+ common:file-exists?
+ common:find-local-megatest
+ common:generic-ssh
+ common:get-area-path-signature
+ common:get-color-from-status
+ common:get-cpu-load
+ common:get-create-writeable-dir
+ common:get-fields
+ common:get-intercept
+ common:get-megatest-exe
+ common:get-megatest-exe-dir
+ common:get-megatest-exe-path
+ common:get-mtexe
+ common:get-normalized-cpu-load
+ common:get-normalized-cpu-load
+ common:get-num-cpus
+ common:get-param-mapping
+ common:get-signature
+ common:get-toppath
+ common:hms-string->seconds
+ common:htree->html
+ common:human-time
+ common:in-running-test?
+ common:join-backgrounded-threads
+ common:lazy-sqlite-db-modification-time
+ common:list->htree
+ common:list-or-null
+ common:logpro-exit-code->status-sym
+ common:low-noise-print
+ common:make-tmpdir-name
+ common:max
+ common:min-max
+ common:nice-path
+ nice-path
+ common:pkts-spec
+ common:raw-get-remote-host-load
+ common:read-encoded-string
+ common:real-path
+ common:send-thunk-to-background-thread
+ common:simple-file-lock
+ common:simple-file-lock-and-wait
+ common:simple-file-release-lock
+ common:sparse-list-generate-index
+ common:special-sort
+ common:steps-can-proceed-given-status-sym
+ common:sum
+ common:to-alist
+ common:unix-ping
+ common:val->alist
+ common:version-signature
+ common:which
+ common:with-env-vars
+ common:without-vars
+ common:worse-status-sym
+ commonmod:get-cpu-load
+ commonmod:is-test-alive
+ db:mintest-get-event_time
+ db:patt->like
+
+ db:test-data-get-category
+ db:test-data-get-comment
+ db:test-data-get-expected
+ db:test-data-get-id
+ db:test-data-get-last_update
+ db:test-data-get-status
+ db:test-data-get-test_id
+ db:test-data-get-tol
+ db:test-data-get-type
+ db:test-data-get-units
+ db:test-data-get-value
+ db:test-data-get-variable
+ db:test-get-archived
+ db:test-get-comment
+ db:test-get-cpuload
+ db:test-get-diskfree
+ db:test-get-event_time
+ db:test-get-final_logf
+ db:test-get-fullname
+ db:test-get-host
+ db:test-get-id
+ db:test-get-is-toplevel
+ db:test-get-item-path
+ db:test-get-last_update
+ db:test-get-process_id
+ db:test-get-run_duration
+ db:test-get-run_id
+ db:test-get-rundir
+ db:test-get-state
+ db:test-get-status
+ db:test-get-testname
+ db:test-get-uname
+ db:test-make-full-name
+ db:test-set-state!
+ db:test-set-status!
+ db:test-set-testname!
+
+ db:testmeta-get-author
+ db:testmeta-get-description
+ db:testmeta-get-owner
+ db:testmeta-get-reviewed
+ db:testmeta-get-tags
+
+ get-area-path-signature
+ get-normalized-cpu-load
+ getenv
+ host-last-cpuload
+ host-last-cpuload-set!
+ host-last-update
+ host-last-update-set!
+ host-last-used
+ host-last-used-set!
+ host-reachable
+ host-reachable-set!
+ item-list->path
+ keys->keystr
+ keys->valslots
+ keys:config-get-fields
+ keys:target->keyval
+ keys:target-set-args
+ make-db:testmeta
+ make-host
+ make-sparse-array
+ make-tests:testqueue
+ megatest-fossil-hash
+ megatest-version
+ number-of-processes-running
+ patt-list-match
+ rmt:transport-mode
+ runs:get-std-run-fields
+ safe-setenv
+ save-environment-as-files
+ sdb:qry
+ seconds->hr-min-sec
+ seconds->quarter
+ seconds->time-string
+ seconds->work-week/day
+ seconds->work-week/day-time
+ seconds->year-work-week/day-time
+ setenv
+ sparse-array-ref
+ sparse-array-set!
+ status-sym->string
+ stop-the-train
+ tasks:wait-on-journal
+
+ tdb:step-get-comment
+ tdb:step-get-event_time
+ tdb:step-get-id
+ tdb:step-get-last_update
+ tdb:step-get-logfile
+ tdb:step-get-state
+ tdb:step-get-status
+ tdb:step-get-stepname
+ tdb:step-get-test_id
+ tdb:steps-table-get-end
+ tdb:steps-table-get-log-file
+ tdb:steps-table-get-runtime
+ tdb:steps-table-get-start
+ tdb:steps-table-get-status
+ tdb:steps-table-get-stepname
+
+ tests:glob-like-match
+ tests:lookup-itemmap
+ tests:match
+ tests:match->sqlqry
+
+ tests:testqueue-get-item_path
+ tests:testqueue-get-itemdat
+ tests:testqueue-get-items
+ tests:testqueue-get-priority
+ tests:testqueue-get-testconfig
+ tests:testqueue-get-testname
+ tests:testqueue-get-waitons
+ tests:testqueue-set-item_path!
+ tests:testqueue-set-itemdat!
+ tests:testqueue-set-items!
+ tests:testqueue-set-priority!
+
+ val->alist
+ )
+
(import scheme)
(cond-expand
(chicken-4
(import chicken
@@ -120,10 +362,12 @@
srfi-69
typed-records
system-information
debugprint
+ megatest-fossil-hash
+
)))
;;======================================================================
;; CONTENTS
;;
@@ -133,10 +377,13 @@
;;
;;======================================================================
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+(include "common_records.scm")
;; http - use the old http + in /tmp db
;; tcp - use tcp transport with cachedb db
;; nfs - use direct to disk access (read-only)
;;
@@ -281,10 +528,11 @@
(caddr argv))
(else (car argv))))
(fullpath (realpath this-script)))
fullpath))
+;; get rid of these, no need to slow down start up
;;======================================================================
(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*))
@@ -381,10 +629,11 @@
(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
;; environment vars handy stuff from common.scm
;;
(define getenv get-environment-variable)
+
(define (safe-setenv key val)
(if (or (substring-index "!" key)
(substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
(substring-index "." key)) ;; periods are not allowed in environment variables
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
@@ -559,13 +808,10 @@
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
-(define (get-section cfgdat section)
- (hash-table-ref/default cfgdat section '()))
-
(define (common:make-tmpdir-name areapath tmpadj)
(let* ((area (pathname-file areapath))
(dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
@@ -626,13 +872,10 @@
;;======================================================================
;; old stuff from keys.scm
;;======================================================================
-(include "key_records.scm")
-(include "common_records.scm")
-
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
(string-intersperse keys ","))
;; (define (args:usage . a) #f)
@@ -2734,7 +2977,229 @@
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
+
+;;======================================================================
+;; db_records.scm
+;;======================================================================
+
+;;======================================================================
+;; dbstruct
+;;======================================================================
+
+(define (make-db:test)(make-vector 20))
+(define (db:test-get-id vec) (vector-ref vec 0))
+(define (db:test-get-run_id vec) (vector-ref vec 1))
+(define (db:test-get-testname vec) (vector-ref vec 2))
+(define (db:test-get-state vec) (vector-ref vec 3))
+(define (db:test-get-status vec) (vector-ref vec 4))
+(define (db:test-get-event_time vec) (vector-ref vec 5))
+(define (db:test-get-host vec) (vector-ref vec 6))
+(define (db:test-get-cpuload vec) (vector-ref vec 7))
+(define (db:test-get-diskfree vec) (vector-ref vec 8))
+(define (db:test-get-uname vec) (vector-ref vec 9))
+;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
+(define (db:test-get-rundir vec) (vector-ref vec 10))
+(define (db:test-get-item-path vec) (vector-ref vec 11))
+(define (db:test-get-run_duration vec) (vector-ref vec 12))
+(define (db:test-get-final_logf vec) (vector-ref vec 13))
+(define (db:test-get-comment vec) (vector-ref vec 14))
+(define (db:test-get-process_id vec) (vector-ref vec 16))
+(define (db:test-get-archived vec) (vector-ref vec 17))
+(define (db:test-get-last_update vec) (vector-ref vec 18))
+
+;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
+;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
+(define (db:test-get-fullname vec)
+ (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
+
+;; replace runs:make-full-test-name with this routine
+(define (db:test-make-full-name testname itempath)
+ (if (equal? itempath "") testname (conc testname "/" itempath)))
+
+;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15)))
+;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
+
+(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
+(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
+(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
+(define (db:test-set-state! vec val)(vector-set! vec 3 val))
+(define (db:test-set-status! vec val)(vector-set! vec 4 val))
+(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
+(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
+
+;; Test record utility functions
+
+;; Is a test a toplevel?
+;;
+(define (db:test-get-is-toplevel vec)
+ (and (equal? (db:test-get-item-path vec) "") ;; test is not an item
+ (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
+
+;; make-vector-record "" db mintest id run_id testname state status event_time item_path
+;; RADT => purpose of mintest??
+;;
+(define (make-db:mintest)(make-vector 7))
+(define (db:mintest-get-id vec) (vector-ref vec 0))
+(define (db:mintest-get-run_id vec) (vector-ref vec 1))
+(define (db:mintest-get-testname vec) (vector-ref vec 2))
+(define (db:mintest-get-state vec) (vector-ref vec 3))
+(define (db:mintest-get-status vec) (vector-ref vec 4))
+(define (db:mintest-get-event_time vec) (vector-ref vec 5))
+(define (db:mintest-get-item_path vec) (vector-ref vec 6))
+
+;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
+(define (make-db:testmeta)(make-vector 10 ""))
+(define (db:testmeta-get-id vec) (vector-ref vec 0))
+(define (db:testmeta-get-testname vec) (vector-ref vec 1))
+(define (db:testmeta-get-author vec) (vector-ref vec 2))
+(define (db:testmeta-get-owner vec) (vector-ref vec 3))
+(define (db:testmeta-get-description vec) (vector-ref vec 4))
+(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
+(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
+(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
+(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
+(define (db:testmeta-get-tags vec) (vector-ref vec 9))
+(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
+(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
+(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
+(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
+(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
+(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
+(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
+(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
+(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
+
+;;======================================================================
+;; S I M P L E R U N
+;;======================================================================
+
+;; (defstruct id "runname" "state" "status" "owner" "event_time"
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+(define (make-db:test-data)(make-vector 10))
+(define (db:test-data-get-id vec) (vector-ref vec 0))
+(define (db:test-data-get-test_id vec) (vector-ref vec 1))
+(define (db:test-data-get-category vec) (vector-ref vec 2))
+(define (db:test-data-get-variable vec) (vector-ref vec 3))
+(define (db:test-data-get-value vec) (vector-ref vec 4))
+(define (db:test-data-get-expected vec) (vector-ref vec 5))
+(define (db:test-data-get-tol vec) (vector-ref vec 6))
+(define (db:test-data-get-units vec) (vector-ref vec 7))
+(define (db:test-data-get-comment vec) (vector-ref vec 8))
+(define (db:test-data-get-status vec) (vector-ref vec 9))
+(define (db:test-data-get-type vec) (vector-ref vec 10))
+(define (db:test-data-get-last_update vec) (vector-ref vec 11))
+
+(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
+(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
+(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
+(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
+(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
+(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
+(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
+(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
+(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
+(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
+(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+;; Run steps
+;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
+(define (make-db:step)(make-vector 9))
+(define (tdb:step-get-id vec) (vector-ref vec 0))
+(define (tdb:step-get-test_id vec) (vector-ref vec 1))
+(define (tdb:step-get-stepname vec) (vector-ref vec 2))
+(define (tdb:step-get-state vec) (vector-ref vec 3))
+(define (tdb:step-get-status vec) (vector-ref vec 4))
+(define (tdb:step-get-event_time vec) (vector-ref vec 5))
+(define (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define (tdb:step-get-comment vec) (vector-ref vec 7))
+(define (tdb:step-get-last_update vec) (vector-ref vec 8))
+(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
+(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
+(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
+(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
+(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
+(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
+(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
+
+
+;; The steps table
+(define (make-db:steps-table)(make-vector 5))
+(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
+(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
+(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
+(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
+(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
+(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
+
+(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
+(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
+(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
+(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
+(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
+
+;; ;; The data structure for handing off requests via wire
+;; (define (make-cdb:packet)(make-vector 6))
+;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
+;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1))
+;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2))
+;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
+;; (define (cdb:packet-get-params vec) (vector-ref vec 4))
+;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5))
+;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
+;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
+;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
+;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
+;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
+;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
+
+;;======================================================================
+;; key_records
+;;======================================================================
+
+(define (keys->valslots keys) ;; => ?,?,? ....
+ (string-intersperse (map (lambda (x) "?") keys) ","))
+
+;; (define (keys->key/field keys . additional)
+;; (string-join (map (lambda (k)(conc k " TEXT"))
+;; (append keys additional)) ","))
+
+(define (item-list->path itemdat)
+ (if (list? itemdat)
+ (string-intersperse (map cadr itemdat) "/")
+ ""))
+
+
+;;======================================================================
+;; test_records
+;;======================================================================
+
+;; make-vector-record tests testqueue testname testconfig waitons priority items
+(define (make-tests:testqueue)(make-vector 7 #f))
+(define (tests:testqueue-get-testname vec) (vector-ref vec 0))
+(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
+(define (tests:testqueue-get-waitons vec) (vector-ref vec 2))
+(define (tests:testqueue-get-priority vec) (vector-ref vec 3))
+;; items: #f=no items, list=list of items remaining, proc=need to call to get items
+(define (tests:testqueue-get-items vec) (vector-ref vec 4))
+(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
+(define (tests:testqueue-get-item_path vec) (vector-ref vec 6))
+
+(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
+(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
+(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
+(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
+(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
+(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
+(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
+
)
ADDED configf-guts.scm
Index: configf-guts.scm
==================================================================
--- /dev/null
+++ configf-guts.scm
@@ -0,0 +1,393 @@
+;;======================================================================
+;; Copyright 2006-2012, 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 .
+
+;;======================================================================
+
+;;======================================================================
+;; Config file handling
+;;======================================================================
+
+(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))")
+
+
+(define (configf:process-line l ht allow-system #!key (linenum #f))
+ (let loop ((res l))
+ (if (string? res)
+ (let ((matchdat (string-search configf:var-expand-regex res)))
+ (if matchdat
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-seconds))
+ (cmdsym (string->symbol cmdtype))
+ (fullcmd (case cmdsym
+ ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))"))
+ ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
+ ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
+ ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
+ ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
+ ((mtrah) (conc "(lambda (ht)"
+ " (let ((extra \"" cmd "\"))"
+ " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
+ " (if (string-null? extra) \"\" \"/\")"
+ " extra)))"))
+ ((get g)
+ (match (string-split cmd)
+ ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ "(lambda (ht) #f)")))
+ ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ (else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
+ ;; (print "fullcmd=" fullcmd)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print "exn=" (condition->list exn))
+ (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+ (if (or allow-system
+ (not (member cmdtype '("system" "shell" "sh"))))
+ (with-input-from-string fullcmd
+ (lambda ()
+ (set! result ((eval (read)) ht))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}"))))
+ (case cmdsym
+ ((system shell scheme)
+ (let ((delta (- (current-seconds) start-time)))
+ (if (> delta 2)
+ (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
+ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
+ (loop (conc prestr result poststr)))
+ res))
+ res)))
+
+;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
+;;
+(define (configf:read-line p ht allow-processing settings)
+ (let loop ((inl (read-line p)))
+ (let ((cont-line (and (string? inl)
+ (not (string-null? inl))
+ (equal? "\\" (string-take-right inl 1)))))
+ (if cont-line ;; last character is \
+ (let ((nextl (read-line p)))
+ (if (not (eof-object? nextl))
+ (loop (string-append (if cont-line
+ (string-take inl (- (string-length inl) 1))
+ inl)
+ nextl))))
+ (let ((res (case allow-processing ;; if (and allow-processing
+ ;; (not (eq? allow-processing 'return-string)))
+ ((#t #f)
+ (configf:process-line inl ht allow-processing))
+ ((return-string)
+ inl)
+ (else
+ (configf:process-line inl ht allow-processing)))))
+ (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))))))
+
+;; read a config file, returns hash table of alists
+
+;; read a config file, returns hash table of alists
+;; adds to ht if given (must be #f otherwise)
+;; allow-system:
+;; #f - do not evaluate [system
+;; #t - immediately evaluate [system and store result as string
+;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
+;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
+;; envion-patt is a regex spec that identifies sections that will be eval'd
+;; in the environment on the fly
+;; sections: #f => get all, else list of sections to gather
+;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
+;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
+;;
+(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
+ (sections #f) (settings (make-hash-table)) (keep-filenames #f)
+ (post-section-procs '()) (apply-wildcards #t) )
+ (debug:print 9 *default-log-port* "START: " path)
+;; (if *configdat*
+;; (common:save-pkt `((action . read-config)
+;; (f . ,(cond ((string? path) path)
+;; ((port? path) "port")
+;; (else (conc path))))
+;; (T . configf))
+;; *configdat* #t add-only: #t))
+ (if (and (not (port? path))
+ (not (common:file-exists? path))) ;; for case where we are handed a port
+ (begin
+ (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
+ ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
+ #f) ;; (if (not ht)(make-hash-table) ht))
+ (let ((inp (if (string? path)
+ (open-input-file path)
+ path)) ;; we can be handed a port
+ (res (if (not ht)(make-hash-table) ht))
+ (metapath (if (or (debug:debug-mode 9)
+ keep-filenames)
+ path #f))
+ (process-wildcards (lambda (res curr-section-name)
+ (if (and apply-wildcards
+ (or (string-contains curr-section-name "%") ;; wildcard
+ (string-match "/.*/" curr-section-name))) ;; regex
+ (begin
+ (configf:apply-wildcards res curr-section-name)
+ (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
+ (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
+ (curr-section-name (if curr-section curr-section "default"))
+ (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
+ (lead #f))
+ (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
+ (if (eof-object? inl)
+ (begin
+ ;; process last section for wildcards
+ (process-wildcards res curr-section-name)
+ (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
+ (close-input-port inp))
+ (if (list? sections) ;; delete all sections except given when sections is provided
+ (for-each
+ (lambda (section)
+ (if (not (member section sections))
+ (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
+ (hash-table-keys res)))
+ (debug:print 9 *default-log-port* "END: " path)
+ res
+ ) ;; retval
+ (regex-case
+ inl
+ (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+
+ (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+ (configf:settings ( x setting val )
+ (begin
+ (hash-table-set! settings setting val)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+
+ (configf:include-rx ( x include-file )
+ (let* ((curr-conf-dir (pathname-directory path))
+ (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
+ include-file
+ (common:nice-path
+ (conc (if curr-conf-dir
+ curr-conf-dir
+ ".")
+ "/" include-file)))))
+ (let ((all-matches (sort (handle-exceptions exn
+ (begin
+ (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
+ (list))
+ (glob full-conf)) string<=?)))
+ (if (null? all-matches)
+ (begin
+ (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf))
+ (for-each
+ (lambda (fpath)
+ ;; (push-directory conf-dir)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
+ (read-config fpath res allow-system environ-patt: environ-patt
+ curr-section: curr-section-name sections: sections settings: settings
+ keep-filenames: keep-filenames))
+ all-matches))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))))
+ (configf:script-rx ( x include-script params);; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
+ ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (if (and (common:file-exists? include-script)(file-execute-access? include-script))
+ (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (new-inp-port
+ (common:with-env-vars
+ env-delta
+ (lambda ()
+ (open-input-pipe (conc include-script " " params))))))
+ (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
+ ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
+ (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
+ (close-input-port new-inp-port)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (begin
+ (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+ ) ;; )
+ (configf:section-rx ( x section-name )
+ (begin
+ ;; call post-section-procs
+ (for-each
+ (lambda (dat)
+ (let ((patt (car dat))
+ (proc (cdr dat)))
+ (if (string-match patt curr-section-name)
+ (proc curr-section-name section-name res path))))
+ post-section-procs)
+ ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
+ ;; NOTE: we are processing the curr-section-name, NOT section-name.
+ (process-wildcards res curr-section-name)
+ (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ ;; if we have the sections list then force all settings into "" and delete it later?
+ ;; (if (or (not sections)
+ ;; (member section-name sections))
+ ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
+ section-name
+ #f #f)))
+ (configf:key-sys-pr ( x key cmd )
+ (if (calc-allow-system allow-system curr-section-name sections)
+ (let ((alist (hash-table-ref/default res curr-section-name '()))
+ (val-proc (lambda ()
+ (let* ((start-time (current-seconds))
+ (local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
+ (delta (- (current-seconds) start-time))
+ (status (cadr cmdres))
+ (res (car cmdres)))
+ (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
+ (if (not (eq? status 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
+ " output: " cmdres)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
+ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
+ (if (null? res)
+ ""
+ (string-intersperse res " "))))))
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist
+ key
+ (case (calc-allow-system allow-system curr-section-name sections)
+ ((return-procs) val-proc)
+ ((return-string) cmd)
+ (else (val-proc)))
+ metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name #f #f)))
+
+ (configf:key-no-val ( x key val)
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
+ (safe-setenv key fval)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist key fval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name key #f)))
+
+ (configf:key-val-pr ( x key unk1 val unk2 )
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (envar (and environ-patt
+ (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt?
+ (and (not (string-null? key))
+ (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
+ ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
+ ))
+ (realval (if envar
+ (configf:eval-string-in-environment val)
+ val)))
+ (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+ (if envar (safe-setenv key realval))
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist key realval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name key #f)))
+ ;; if a continued line
+ (configf:cont-ln-rx ( x whsp val )
+ (let ((alist (hash-table-ref/default res curr-section-name '())))
+ (if var-flag ;; if set to a string then we have a continued var
+ (let ((newval (conc
+ (configf:lookup res curr-section-name var-flag) "\n"
+ ;; trim lead from the incoming whsp to support some indenting.
+ (if lead
+ (string-substitute (regexp lead) "" whsp)
+ "")
+ val)))
+ ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist var-flag newval metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
+ (set! var-flag #f)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ ) ;; end loop
+ )))
+
+(define (setup)
+ (let* ((configf (find-config "megatest.config"))
+ (config (if configf (read-config configf #f #t) #f)))
+ (if config
+ (setenv "RUN_AREA_HOME" (pathname-directory configf)))
+ config))
+
+;;======================================================================
+;; refdb
+;;======================================================================
+
+;; reads a refdb into an assoc array of assoc arrays
+;; returns (list dat msg)
+(define (configf:read-refdb refdb-path)
+ (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
+ (if (not (common:file-exists? sheets-file))
+ (list #f (conc "ERROR: no refdb found at " refdb-path))
+ (if (not (file-read-access? sheets-file))
+ (list #f (conc "ERROR: refdb file not readable at " refdb-path))
+ (let* ((sheets (with-input-from-file sheets-file
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (loop (read-line)(cons inl res)))))))
+ (data '()))
+ (for-each
+ (lambda (sheet-name)
+ (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
+ (ref-dat (configf:read-file dat-path #f #t))
+ (ref-assoc (map (lambda (key)
+ (list key (hash-table-ref ref-dat key)))
+ (hash-table-keys ref-dat))))
+ ;; (hash-table->alist ref-dat)))
+ ;; (set! data (append data (list (list sheet-name ref-assoc))))))
+ (set! data (cons (list sheet-name ref-assoc) data))))
+ sheets)
+ (list data "NO ERRORS"))))))
+
+;; redefines
+(define config-lookup configf:lookup)
+(define configf:read-file read-config)
+
DELETED configf.scm
Index: configf.scm
==================================================================
--- configf.scm
+++ /dev/null
@@ -1,426 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 .
-
-;;======================================================================
-
-;;======================================================================
-;; Config file handling
-;;======================================================================
-
-(use regex regex-case matchable) ;; directory-utils)
-(declare (unit configf))
-(declare (uses process))
-(declare (uses env))
-(declare (uses keys))
-(declare (uses debugprint))
-(declare (uses mtargs))
-(declare (uses mtargs.import))
-(declare (uses common))
-(declare (uses commonmod))
-(declare (uses commonmod.import))
-(declare (uses processmod))
-(declare (uses processmod.import))
-(declare (uses configfmod))
-(declare (uses configfmod.import))
-(declare (uses dbfile))
-(declare (uses dbfile.import))
-(declare (uses dbmod))
-(declare (uses dbmod.import))
-(declare (uses mtmod))
-(declare (uses mtmod.import))
-
-(import commonmod
- configfmod
- processmod
- (prefix mtargs args:)
- debugprint
- mtmod
- )
-
-(include "common_records.scm")
-
-(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))")
-
-
-(define (configf:process-line l ht allow-system #!key (linenum #f))
- (let loop ((res l))
- (if (string? res)
- (let ((matchdat (string-search configf:var-expand-regex res)))
- (if matchdat
- (let* ((prestr (list-ref matchdat 1))
- (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
- (cmd (list-ref matchdat 3))
- (poststr (list-ref matchdat 4))
- (result #f)
- (start-time (current-seconds))
- (cmdsym (string->symbol cmdtype))
- (fullcmd (case cmdsym
- ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))"))
- ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
- ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
- ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
- ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
- ((mtrah) (conc "(lambda (ht)"
- " (let ((extra \"" cmd "\"))"
- " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
- " (if (string-null? extra) \"\" \"/\")"
- " extra)))"))
- ((get g)
- (match (string-split cmd)
- ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
- (else
- (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
- "(lambda (ht) #f)")))
- ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
- ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
- (else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
- ;; (print "fullcmd=" fullcmd)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- ;; (print "exn=" (condition->list exn))
- (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
- (if (or allow-system
- (not (member cmdtype '("system" "shell" "sh"))))
- (with-input-from-string fullcmd
- (lambda ()
- (set! result ((eval (read)) ht))))
- (set! result (conc "#{(" cmdtype ") " cmd "}"))))
- (case cmdsym
- ((system shell scheme)
- (let ((delta (- (current-seconds) start-time)))
- (if (> delta 2)
- (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
- (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
- (loop (conc prestr result poststr)))
- res))
- res)))
-
-;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
-;;
-(define (configf:read-line p ht allow-processing settings)
- (let loop ((inl (read-line p)))
- (let ((cont-line (and (string? inl)
- (not (string-null? inl))
- (equal? "\\" (string-take-right inl 1)))))
- (if cont-line ;; last character is \
- (let ((nextl (read-line p)))
- (if (not (eof-object? nextl))
- (loop (string-append (if cont-line
- (string-take inl (- (string-length inl) 1))
- inl)
- nextl))))
- (let ((res (case allow-processing ;; if (and allow-processing
- ;; (not (eq? allow-processing 'return-string)))
- ((#t #f)
- (configf:process-line inl ht allow-processing))
- ((return-string)
- inl)
- (else
- (configf:process-line inl ht allow-processing)))))
- (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))))))
-
-;; read a config file, returns hash table of alists
-
-;; read a config file, returns hash table of alists
-;; adds to ht if given (must be #f otherwise)
-;; allow-system:
-;; #f - do not evaluate [system
-;; #t - immediately evaluate [system and store result as string
-;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
-;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
-;; envion-patt is a regex spec that identifies sections that will be eval'd
-;; in the environment on the fly
-;; sections: #f => get all, else list of sections to gather
-;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
-;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
-;;
-(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
- (sections #f) (settings (make-hash-table)) (keep-filenames #f)
- (post-section-procs '()) (apply-wildcards #t) )
- (debug:print 9 *default-log-port* "START: " path)
-;; (if *configdat*
-;; (common:save-pkt `((action . read-config)
-;; (f . ,(cond ((string? path) path)
-;; ((port? path) "port")
-;; (else (conc path))))
-;; (T . configf))
-;; *configdat* #t add-only: #t))
- (if (and (not (port? path))
- (not (common:file-exists? path))) ;; for case where we are handed a port
- (begin
- (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
- ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
- #f) ;; (if (not ht)(make-hash-table) ht))
- (let ((inp (if (string? path)
- (open-input-file path)
- path)) ;; we can be handed a port
- (res (if (not ht)(make-hash-table) ht))
- (metapath (if (or (debug:debug-mode 9)
- keep-filenames)
- path #f))
- (process-wildcards (lambda (res curr-section-name)
- (if (and apply-wildcards
- (or (string-contains curr-section-name "%") ;; wildcard
- (string-match "/.*/" curr-section-name))) ;; regex
- (begin
- (configf:apply-wildcards res curr-section-name)
- (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
- (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
- (curr-section-name (if curr-section curr-section "default"))
- (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
- (lead #f))
- (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
- (if (eof-object? inl)
- (begin
- ;; process last section for wildcards
- (process-wildcards res curr-section-name)
- (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
- (close-input-port inp))
- (if (list? sections) ;; delete all sections except given when sections is provided
- (for-each
- (lambda (section)
- (if (not (member section sections))
- (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
- (hash-table-keys res)))
- (debug:print 9 *default-log-port* "END: " path)
- res
- ) ;; retval
- (regex-case
- inl
- (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f))
-
- (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f))
- (configf:settings ( x setting val )
- (begin
- (hash-table-set! settings setting val)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f)))
-
- (configf:include-rx ( x include-file )
- (let* ((curr-conf-dir (pathname-directory path))
- (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
- include-file
- (common:nice-path
- (conc (if curr-conf-dir
- curr-conf-dir
- ".")
- "/" include-file)))))
- (let ((all-matches (sort (handle-exceptions exn
- (begin
- (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
- (list))
- (glob full-conf)) string<=?)))
- (if (null? all-matches)
- (begin
- (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
- (debug:print 2 *default-log-port* " " full-conf))
- (for-each
- (lambda (fpath)
- ;; (push-directory conf-dir)
- (debug:print 9 *default-log-port* "Including: " full-conf)
- (read-config fpath res allow-system environ-patt: environ-patt
- curr-section: curr-section-name sections: sections settings: settings
- keep-filenames: keep-filenames))
- all-matches))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f))))
- (configf:script-rx ( x include-script params);; handle-exceptions
- ;; exn
- ;; (begin
- ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
- ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (if (and (common:file-exists? include-script)(file-execute-access? include-script))
- (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
- (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
- (new-inp-port
- (common:with-env-vars
- env-delta
- (lambda ()
- (open-input-pipe (conc include-script " " params))))))
- (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
- ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
- (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
- (close-input-port new-inp-port)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (begin
- (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
- ) ;; )
- (configf:section-rx ( x section-name )
- (begin
- ;; call post-section-procs
- (for-each
- (lambda (dat)
- (let ((patt (car dat))
- (proc (cdr dat)))
- (if (string-match patt curr-section-name)
- (proc curr-section-name section-name res path))))
- post-section-procs)
- ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
- ;; NOTE: we are processing the curr-section-name, NOT section-name.
- (process-wildcards res curr-section-name)
- (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- ;; if we have the sections list then force all settings into "" and delete it later?
- ;; (if (or (not sections)
- ;; (member section-name sections))
- ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
- section-name
- #f #f)))
- (configf:key-sys-pr ( x key cmd )
- (if (calc-allow-system allow-system curr-section-name sections)
- (let ((alist (hash-table-ref/default res curr-section-name '()))
- (val-proc (lambda ()
- (let* ((start-time (current-seconds))
- (local-allow-system (calc-allow-system allow-system curr-section-name sections))
- (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
- (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
- (delta (- (current-seconds) start-time))
- (status (cadr cmdres))
- (res (car cmdres)))
- (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
- (if (not (eq? status 0))
- (begin
- (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
- " output: " cmdres)))
- (if (> delta 2)
- (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
- (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
- (if (null? res)
- ""
- (string-intersperse res " "))))))
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist
- key
- (case (calc-allow-system allow-system curr-section-name sections)
- ((return-procs) val-proc)
- ((return-string) cmd)
- (else (val-proc)))
- metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (loop (configf:read-line inp res
- (calc-allow-system allow-system curr-section-name sections)
- settings)
- curr-section-name #f #f)))
-
- (configf:key-no-val ( x key val)
- (let* ((alist (hash-table-ref/default res curr-section-name '()))
- (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
- (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
- (safe-setenv key fval)
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist key fval metadata: metapath))
- (loop (configf:read-line inp res
- (calc-allow-system allow-system curr-section-name sections)
- settings)
- curr-section-name key #f)))
-
- (configf:key-val-pr ( x key unk1 val unk2 )
- (let* ((alist (hash-table-ref/default res curr-section-name '()))
- (envar (and environ-patt
- (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt?
- (and (not (string-null? key))
- (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
- ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
- ))
- (realval (if envar
- (configf:eval-string-in-environment val)
- val)))
- (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
- (if envar (safe-setenv key realval))
- (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist key realval metadata: metapath))
- (loop (configf:read-line inp res
- (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name key #f)))
- ;; if a continued line
- (configf:cont-ln-rx ( x whsp val )
- (let ((alist (hash-table-ref/default res curr-section-name '())))
- (if var-flag ;; if set to a string then we have a continued var
- (let ((newval (conc
- (configf:lookup res curr-section-name var-flag) "\n"
- ;; trim lead from the incoming whsp to support some indenting.
- (if lead
- (string-substitute (regexp lead) "" whsp)
- "")
- val)))
- ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist var-flag newval metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
- (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
- (set! var-flag #f)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
- ) ;; end loop
- )))
-
-(define (setup)
- (let* ((configf (find-config "megatest.config"))
- (config (if configf (read-config configf #f #t) #f)))
- (if config
- (setenv "RUN_AREA_HOME" (pathname-directory configf)))
- config))
-
-;;======================================================================
-;; refdb
-;;======================================================================
-
-;; reads a refdb into an assoc array of assoc arrays
-;; returns (list dat msg)
-(define (configf:read-refdb refdb-path)
- (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
- (if (not (common:file-exists? sheets-file))
- (list #f (conc "ERROR: no refdb found at " refdb-path))
- (if (not (file-read-access? sheets-file))
- (list #f (conc "ERROR: refdb file not readable at " refdb-path))
- (let* ((sheets (with-input-from-file sheets-file
- (lambda ()
- (let loop ((inl (read-line))
- (res '()))
- (if (eof-object? inl)
- (reverse res)
- (loop (read-line)(cons inl res)))))))
- (data '()))
- (for-each
- (lambda (sheet-name)
- (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
- (ref-dat (configf:read-file dat-path #f #t))
- (ref-assoc (map (lambda (key)
- (list key (hash-table-ref ref-dat key)))
- (hash-table-keys ref-dat))))
- ;; (hash-table->alist ref-dat)))
- ;; (set! data (append data (list (list sheet-name ref-assoc))))))
- (set! data (cons (list sheet-name ref-assoc) data))))
- sheets)
- (list data "NO ERRORS"))))))
-
-;; redefines
-(define config-lookup configf:lookup)
-(define configf:read-file read-config)
-(define shell configfmod#shell)
-
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -25,11 +25,37 @@
(declare (uses mtargs))
(use regex regex-case)
(module configfmod
-*
+ (
+ configf:map-all-hier-alist
+ configf:read-refdb
+ lookup
+ configf:lookup
+ get-section
+ configf:get-section
+ configf:lookup-number
+ read-config
+ runconfigs-get
+ configf:section-vars
+ configf:read-alist
+ configf:config->alist
+ configf:alist->config
+ configf:set-section-var
+
+ find-and-read-config
+ common:args-get-target
+ configf:eval-string-in-environment
+
+ read-config-set!
+ configf:read-file
+
+ configf:system
+ configf:config->ini
+ shell
+ )
(import scheme
chicken
extras
files
@@ -203,10 +229,12 @@
(if match ;; (and match (list? match)(> (length match) 1))
(cadr match)
#f))
))
#f))
+
+(define lookup configf:lookup)
;; use to have definitive setting:
;; [foo]
;; var yes
;;
@@ -234,10 +262,12 @@
'()
(map car sectdat))))
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
+
+(define get-section configf:get-section)
(define (configf:set-section-var cfgdat section var val)
(let ((sectdat (configf:get-section cfgdat section)))
(hash-table-set! cfgdat section
(configf:assoc-safe-add sectdat var val))))
@@ -473,8 +503,44 @@
(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))))
+
+;;======================================================================
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;;
+(define (runconfigs-get config var)
+ (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+ (if targ
+ (or (configf:lookup config targ var)
+ (configf:lookup config "default" var))
+ (configf:lookup config "default" var))))
+
+(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
+ (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
+ (numkeys (length keys))
+ (target (or (args:get-arg "-reqtarg")
+ (args:get-arg "-target")
+ (getenv "MT_TARGET")))
+ (tlist (if target (string-split target "/" #t) '()))
+ (valid (if target
+ (or (null? keys) ;; probably don't know our keys yet
+ (and (not (null? tlist))
+ (eq? numkeys (length tlist))
+ (null? (filter string-null? tlist))))
+ #f)))
+ (if valid
+ (if split
+ tlist
+ target)
+ (if target
+ (begin
+ (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
+ (if exit-if-bad (exit 1))
+ #f)
+ #f))))
+
+(include "configf-guts.scm")
)
Index: configure
==================================================================
--- configure
+++ configure
@@ -15,87 +15,91 @@
# 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
- CSIPATH=$(which csi)
- 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"
+
+
+
+# # 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
+# CSIPATH=$(which csi)
+# 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: cpumod.scm
==================================================================
--- cpumod.scm
+++ cpumod.scm
@@ -29,11 +29,12 @@
(declare (uses mtargs))
(use srfi-69)
(module cpumod
- *
+ ()
+
(import scheme)
(cond-expand
(chicken-4
DELETED dashboard-context-menu.scm
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ /dev/null
@@ -1,361 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 .
-
-;;======================================================================
-
-;;======================================================================
-;; implementation of context menu that pops up on
-;; right click on test cell in Runs & Runs Summary Tabs
-;;======================================================================
-
-(declare (unit dashboard-context-menu))
-(declare (uses common))
-(declare (uses commonmod))
-(declare (uses configfmod))
-(declare (uses db))
-(declare (uses gutils))
-(declare (uses rmtmod))
-(declare (uses ezsteps))
-;; (declare (uses sdb))
-;; (declare (uses filedb))
-(declare (uses subrun))
-(declare (uses testsmod))
-(declare (uses subrunmod))
-
-(use format fmt)
-(require-library iup)
-(import (prefix iup iup:))
-
-(use canvas-draw)
-
-(use srfi-1 posix regex regex-case srfi-69)
-(use (prefix sqlite3 sqlite3:))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
-(import commonmod
- configfmod
- rmtmod
- testsmod
- subrunmod
- debugprint)
-
-(define (dboard:launch-testpanel 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)
- (list
- (iup:menu-item
- (conc "Rerun " testpatt)
- #:action
- (lambda (obj)
- ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
- (common:run-a-command
- (conc "megatest -run -target " target
- " -runname " runname
- " -testpatt " testpatt
- " -preclean -clean-cache")
- )))
- (iup:menu-item
- "Rerun Complete Run"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
- " -runname " runname
- " -testpatt % "
- " -preclean -clean-cache"))))
- (iup:menu-item
- "Clean Complete Run"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt % "))))
- (iup:menu-item
- "Kill Complete Run"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status KILLREQ,n/a -target " target
- " -runname " runname
- " -testpatt % "
- " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
- (iup:menu-item
- "Delete Run Data"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt % "
- " -keep-records"))))))
-
-(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
- (list
- (iup:menu-item
- (conc "Rerun " item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -preclean -clean-cache"))))
- (iup:menu-item
- (conc "Kill " item-test-path)
- #:action
- (lambda (obj)
- ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
- (common:run-a-command
- (conc "megatest -set-state-status KILLREQ,n/a -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
- (iup:menu-item
- (conc "Delete data : " item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -keep-records"))))
- (iup:menu-item
- (conc "Clean "item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt " item-test-path))))
- (iup:menu-item
- "Start xterm"
- #:action
- (lambda (obj)
- (dcommon:examine-xterm run-id test-id)))
- ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
- ;; (system cmd))))
- (iup:menu-item
- "Edit testconfig"
- #:action
- (lambda (obj)
- (let* ((all-tests (tests:get-all))
- (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex")
- "\\b(vim?|nano|pico)\\b"))
- (editor (or (configf:lookup *configdat* "setup" "editor")
- (get-environment-variable "VISUAL")
- (get-environment-variable "EDITOR") "vi"))
- (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
- (cmd (conc (if (string-search editor-rx editor)
- (conc "xterm -e " editor)
- editor)
- " " tconfig " &")))
- (system cmd))))))
-
-(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info)
- (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; #
- (rundir (db:test-get-rundir test-info)))
-
- (iup:menu-item
- "Step logs"
- (apply iup:menu
- (map (lambda (step)
- (let ((stepname (vector-ref step 0))
- (logfile (vector-ref step 5))
- (status (vector-ref step 3)))
- (iup:menu-item
- (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")")
- #:action (lambda (obj)
- (let ((fullfile (conc rundir "/" logfile)))
- (if (common:file-exists? fullfile)
- (dcommon:run-html-viewer fullfile)
- (message-window (conc "file " fullfile " not found"))))))))
- steps)))))
-
-(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
- (list
-
- (iup:menu-item
- "Test Control Panel"
- #:action
- (lambda (obj)
- (dboard:launch-testpanel run-id test-id)))
-
- (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info)
-
- (iup:menu-item
- (conc "Rerun " item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -preclean -clean-cache"))))
-
- (iup:menu-item
- "Start xterm"
- #:action
- (lambda (obj)
- (dcommon:examine-xterm run-id test-id)))
-
- (iup:menu-item
- (conc "Kill " item-test-path)
- #:action
- (lambda (obj)
- ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
- (common:run-a-command
- (conc "megatest -set-state-status KILLREQ,n/a -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
-
- (let* ((rundir (db:test-get-rundir test-info))
- (has-subrun (subrun:subrun-test-initialized? rundir)))
- (if has-subrun
- (iup:menu-item
- "Launch subrun dashboard"
- #:action
- (lambda (obj)
- (subrun:launch-dashboard rundir)))
- (iup:vbox)))
-
- (iup:menu-item
- (conc "View Log " item-test-path)
- #:action
- (lambda (obj)
- (let* ((rundir (db:test-get-rundir test-info))
- (logf (db:test-get-final_logf test-info))
- (fullfile (conc rundir "/" logf)))
- (if (common:file-exists? fullfile)
- (dcommon:run-html-viewer fullfile)
- (message-window (conc "file " fullfile " not found.")))))
- )
- ))
-;; example section for megatest.config:
-;;
-;;
-;; [custom-context-menu-items]
-;; #