Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,13 +1,43 @@ utils/build/* *~ *.o bin/* -tests/megatest.db -tests/monitor.db +megatest.db +monitor.db megatest dboard tests/fullrun/tmp/* tests/simpleruns tests/simplelinks mkdeploy/runs mkdeploy/links +example/linktree +example/runs +*.backup +mkdeploy/linktree +mkdeploy/site.config +deploytarg/* +mtest +newdboard +*.log +fslsync/fslsynclinks/* +fslsync/fslsyncruns/* +sites.dat +fullrun/config/*.config +fullrun/envfile.txt +*.bak +simplerun/*.scm +simplerun/simpleruns +tests/mintest/runs/* +tests/mintest/linktree/* +tests/installall/stdrel/* +tests/installall/runs/* +tests/installall/links/* +tests/fdktestqa/simpleruns/* +tests/installall/megatest.db +tests/installall/monitor.db +tests/megatest.db +tests/fdktestqa/simplelinks/* +tests/fdktestqa/testqa/megatest.db +tests/fdktestqa/testqa/monitor.db +megatest-fossil-hash.scm Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,15 +1,23 @@ - +# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - fs-transport.scm http-transport.scm \ - client.scm gutils.scm synchash.scm daemon.scm + http-transport.scm filedb.scm \ + client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ + tree.scm ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm tdb.scm portlogger.scm + +# Eggs to install (straightforward ones) +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ + dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -19,45 +27,45 @@ DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') CSIPATH=$(shell which csi) CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) +# ARCHSTR=$(shell uname -m)_$(shell uname -r) +# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") +# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) +ARCHSTR=$(shell lsb_release -sr) +# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") + +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard txtdb -all : mtest dboard newdboard +refdb : txtdb/txtdb.scm + csc -I txtdb txtdb/txtdb.scm -o refdb mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard -newdboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard - -deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so - for i in iup im cd av call sqlite; do \ - cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ - done - cp $(CKPATH)/include/*.h deploytarg - -# puts deployed megatest in directory "megatest" -deploytarg/megatest : $(OFILES) megatest.o - csc -deploy $(CSCOPTS) $(OFILES) megatest.scm - rsync -av megatest/ deploytarg/ - -deploytarg/dashboard : $(OFILES) $(GOFILES) - csc -deploy $(OFILES) $(GOFILES) dashboard.scm - rsync -av dashboard/ deploytarg/ - +ndboard : newdashboard.scm $(OFILES) $(GOFILES) + csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard + +# +# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm +# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm +client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm + +# Temporary while transitioning to new routine +# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi @@ -64,36 +72,46 @@ $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< -$(PREFIX)/bin/mtest : mtest +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest @echo Installing to PREFIX=$(PREFIX) - $(INSTALL) mtest $(PREFIX)/bin/mtest - utils/mk_wrapper $(PREFIX) mtest > $(PREFIX)/bin/megatest + $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest + utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest -$(PREFIX)/bin/newdboard : newdboard - $(INSTALL) newdboard $(PREFIX)/bin/newdboard - utils/mk_wrapper $(PREFIX) newdboard > $(PREFIX)/bin/newdashboard +$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard + $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard + utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(HELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+x $@ -$(DEPLOYHELPERS) : utils/mt_* +$(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ - chmod a+X $@ + chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/loadrunner : utils/loadrunner + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/refdb : refdb + $(INSTALL) $< $@ + chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ @@ -101,32 +119,67 @@ $(INSTALL) $< $@ chmod a+x $@ # install dashboard as dboard so wrapper script can be called dashboard -$(PREFIX)/bin/dboard : dboard $(FILES) - $(INSTALL) dboard $(PREFIX)/bin/dboard - utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) + utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard - -install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard - -deploytarg/apropos.so : Makefile - for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ - chicken-install -prefix deploytarg -deploy $$i;done - -deploytarg/libsqlite3.so : - CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 - - - -deploy : deploytarg/megatest deploytarg/dashboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/libiupcd.so deploytarg/apropos.so - - -bin : - mkdir -p $(PREFIX)/bin + $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard + +install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ + $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/bin/newdashboard + +$(PREFIX)/bin/.$(ARCHSTR) : + mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm clean : - rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o + +# Deploy section (not complete yet) +# +$(DEPLOYHELPERS) : utils/mt_* + $(INSTALL) $< $@ + chmod a+X $@ + +deploytarg/apropos.so : Makefile + chicken-install -p deploytarg -deploy $(EGGS) + +# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ +# chicken-install -prefix deploytarg -deploy $$i;done + +# deploytarg/libsqlite3.so : +# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 + +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/apropos.so + +# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so +# for i in iup im cd av call sqlite; do \ +# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ +# done +# cp $(CKPATH)/include/*.h deploytarg + +# puts deployed megatest in directory "megatest" +deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so + csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/mtest + +deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so + csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/dboard + +# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ +# megatest-version.o tdb.o ods.o mt.o keys.o +datashare-testing/sd : datashare.scm $(OFILES) + csc datashare.scm $(OFILES) -o datashare-testing/sd + +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 &) + Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -1,7 +1,116 @@ +====================================================================== +Try writing to in-memory db and every 2-5 seconds syncing to megatest.db +====================================================================== + +First, how much time will it take to write back the changes: + +1. Get the run table + +(define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res)) +(define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res)) + +Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs + +Projecting to 15000 records: + + Slow 2 seconds to read all + Median 1 second to read all + +This seems like it would work with an update period of 2-5 seconds + +TODO +---- + +1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh > +2. Server is part of runtests + a. server start cycle - adapt to per run-id + i. states; starting, started, stopping, stopped + b. turn off write coalesing +3. Calls to -runtests, -remove-runs etc. + a. Might talk to running server if run specific + b. Can talk to megatest.db but not a generally good idea + c. Can start a runserver +4. Dashboard is fine except for writes? + +====================================================================== +Routines to convert for runs.scm + +cdb:remote-run db:register-run + +cdb:delete-tests-in-state *runremote* +cdb:get-test-info-by-id *runremote* +cdb:remote-run db:delete-old-deleted-test-records +cdb:remote-run db:delete-run +cdb:remote-run db:delete-test-records +cdb:remote-run db:delete-tests-for-run +cdb:remote-run db:find-and-mark-incomplete +cdb:remote-run db:get-count-tests-running +cdb:remote-run db:get-count-tests-running-in-jobgroup +cdb:remote-run db:get-keys +cdb:remote-run db:get-run-info +cdb:remote-run db:get-run-key-val +cdb:remote-run db:get-run-name-from-id +cdb:remote-run db:get-steps-for-test +cdb:remote-run db:get-test-id-cached +cdb:remote-run db:get-tests-for-runs-mindata +cdb:remote-run db:lock/unlock-run +cdb:remote-run db:set-sync +cdb:remote-run db:set-tests-state-status +cdb:remote-run db:set-var +cdb:remote-run db:testmeta-add-record +cdb:remote-run db:testmeta-get-record +cdb:remote-run db:testmeta-update-field +cdb:remote-run db:update-run-event_time +cdb:remote-run instead +cdb:remote-run server:start +cdb:remote-run test:get-matching-previous-test-run-records +cdb:tests-register-test *runremote* +(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run + +====================================================================== + +[87cbe68f31] +[be405e8e2e] + +# FROM andyjpg on #chicken + +(let ((original-exit (exit-handler))) + (exit-handler (lambda (#!optional (exit-code 0)) + (printf "Preparing to exit...\n" exit-code) + (for-each (lambda (pid) + (printf "Sending signal/term to ~A\n" pid) + (process-signal pid signal/term)) (children)) + (original-exit exit-code)))) + + + 1. All run control access to db is direct. 2. All test machines must have megatest available 3. Tests may or may not have file system access to the originating run area. rsync is used to pull the test area to the home host if and only if the originating area can not be seen via file system. NO LONGER TRUE. Rsync is used but file system must be visible. 4. All db access is done via the home host. NOT IMPLEMENTED YET. + +REMOTE ACCESS DB LOADS + +INFO: (0) Max cached queries was 10 +INFO: (0) Number of cached writes 27043 +INFO: (0) Average cached write time 15.0634544983915 ms +INFO: (0) Number non-cached queries 71928 +INFO: (0) Average non-cached time 5.15547491936381 ms +INFO: (0) Server shutdown complete. Exiting + + +fdktestqa on Apr 29, 2013: 1812 tests + +INFO: (0) Max cached queries was 10 +INFO: (0) Number of cached writes 41335 +INFO: (0) Average cached write time 206.081553163179 ms +INFO: (0) Number non-cached queries 74289 +INFO: (0) Average non-cached time 1055.09826488444 ms +INFO: (0) Server shutdown complete. Exiting + +Start: 0 at Sun Apr 28 22:18:25 MST 2013 +Max: 52 at Sun Apr 28 23:06:59 MST 2013 +End: 6 at Sun Apr 28 23:47:51 MST 2013 Index: TODO ================================================================== --- TODO +++ TODO @@ -1,15 +1,12 @@ -1. Run all tests -2. create run areas, copy in conf and scripts DONE -3. Add a host chooser for ssh to launch-tests -4. Run creation timestamp not happening DONE -5 . Check for test already in progress, give meaningful message DONE -6. Debug xterm creation for test generation DONE -7. Capture run info, host, load, freemem at test launch DONE -8. Rename to testalot? Nah! I like Megatest -10. Run, test and step comment field -11. At end of test scan all tests for this run, if all done - update run status to COMPLETED NOT gonna happen. It is up to the test to mark as PASS/FAIL -12. state and status lists need to be regexes -13. Test on Chicken 4. DONE -14. Try making static executable -15. Log processor script DONE + +TODO +==== + +Migration to inmem db plus per run db +------------------------------------- + +. Re-work the dbstruct data structure? +.. Move main.db to global? +.. [ run-id.db inmemdb last-mod last-read last-sync inuse ] +. Re-work all queries to use run-id to dereference server +. Open main.db directly in calls to -runtests etc. No need to talk remote? ADDED api.scm Index: api.scm ================================================================== --- /dev/null +++ api.scm @@ -0,0 +1,155 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(declare (unit api)) +(declare (uses rmt)) +(declare (uses db)) + +;; allow these queries through without starting a server +;; +(define api:read-only-queries + '(get-key-val-pairs + get-keys + test-toplevel-num-items + get-test-info-by-id + test-get-rundir-from-test-id + get-count-tests-running + get-count-tests-running-in-jobgroup + get-previous-test-run-record + get-matching-previous-test-run-records + test-get-logfile-info + test-get-records-for-index-file + get-testinfo-state-status + test-get-top-process-pid + test-get-paths-matching-keynames-target-new + get-prereqs-not-met + get-count-tests-running-for-run-id + get-run-info + get-run-status + register-run + get-tests-for-run + get-test-id + get-tests-for-runs-mindata + get-run-name-from-id + get-runs + get-all-run-ids + get-prev-run-ids + get-run-ids-matching-target + get-runs-by-patt + get-steps-data + login + testmeta-get-record)) + +;; These are called by the server on recipt of /api calls +;; - keep it simple, only return the actual result of the call, i.e. no meta info here +;; +(define (api:execute-requests dbstruct cmd params) + (case (string->symbol cmd) + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) + ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((find-and-mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + + ;; MISC + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:with-db dbstruct run-id #t ;; these are all for modifying the db + (lambda (db) + (db:general-call db stmtname realparams))))) + ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t)) + ((sdb-qry) (apply sdb:qry params)) + + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + (else + (list "ERROR" 0)))) + +;; http-server send-response +;; api:process-request +;; db:* +;; +;; NB// Runs on the server as part of the server loop +;; +(define (api:process-request dbstruct $) ;; the $ is the request vars proc + (let* ((cmd ($ 'cmd)) + (paramsj ($ 'params)) + (params (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj)) + (res (api:execute-requests dbstruct cmd params))) + + ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds + ;; (rmt:dat->json-str + ;; (if (or (string? res) + ;; (list? res) + ;; (number? res) + ;; (boolean? res)) + ;; res + ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) + (db:obj->string res))) + Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -1,6 +1,6 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2014, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -13,5 +13,6 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit archive)) (declare (uses db)) (declare (uses common)) + Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -17,11 +17,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) ;; (use zmq) (import (prefix sqlite3 sqlite3:)) -(use spiffy uri-common intarweb http-client spiffy-request-vars) +(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) (declare (uses common)) (declare (uses db)) @@ -35,14 +35,10 @@ (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) -;; client:login serverdat -(define (client:login serverdat) - (cdb:login serverdat *toppath* (client:get-signature))) - ;; Not currently used! But, I think it *should* be used!!! (define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) @@ -50,50 +46,91 @@ ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline -;; 2. We are a run tests, list runs or other interactive process and we mush figure out +;; 2. We are a run tests, list runs or other interactive process and we must figure out ;; *transport-type* and *runremote* from the monitor.db ;; ;; client:setup -(define (client:setup #!key (numtries 50)) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: failed to find megatest.config, exiting") - (exit)))) - (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) - (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out - (open-run-close tasks:get-best-server tasks:open-db) - #f))) - ;; if have hostinfo then extract the transport type - ;; else fall back to fs - (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) - (set! *transport-type* (if hostinfo - (string->symbol (tasks:hostinfo-get-transport hostinfo)) - 'fs)) - ;; ;; DEBUG STUFF - ;; (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99))) - - (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) - (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) - ((http) - (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo))) - ((zmq) - (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo) - (tasks:hostinfo-get-pubport hostinfo))) - (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))) +;; +;; lookup_server, need to remove *runremote* stuff +;; +(define (client:setup run-id #!key (remaining-tries 100) (failed-connects 0)) + (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) + (let* ((tdbdat (tasks:open-db))) + (if (<= remaining-tries 0) + (begin + (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) + (exit 1)) + (let ((host-info (hash-table-ref/default *runremote* run-id #f))) + (if host-info + (let* ((iface (http-transport:server-dat-get-iface host-info)) + (port (http-transport:server-dat-get-port host-info)) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if ping-res ;; sucessful login? + (begin + (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) + ;; Why add the close-connections here? + ;; (http-transport:close-connections run-id) + (hash-table-set! *runremote* run-id start-res) + start-res) ;; return the server info + ;; have host info but no ping. shutdown the current connection and try again + (begin ;; login failed + (debug:print-info 1 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) + (http-transport:close-connections run-id) + (hash-table-delete! *runremote* run-id) + (if (< remaining-tries 8) + (thread-sleep! 5) + (thread-sleep! 1)) + (client:setup run-id remaining-tries: (- remaining-tries 1))))) + ;; YUK: rename server-dat here + (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) + (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (if server-dat + (let* ((iface (tasks:hostinfo-get-interface server-dat)) + (port (tasks:hostinfo-get-port server-dat)) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if (and start-res + ping-res) + (begin + (hash-table-set! *runremote* run-id start-res) + (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) + start-res) + (begin ;; login failed but have a server record, clean out the record and try again + (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (http-transport:close-connections run-id) + (hash-table-delete! *runremote* run-id) + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) + run-id + (tasks:hostinfo-get-interface server-dat) + (tasks:hostinfo-get-port server-dat) + " client:setup (server-dat = #t)") + (thread-sleep! 2) + (server:try-running run-id) + (thread-sleep! 10) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1))))) + (begin ;; no server registered + (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) + (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + (thread-sleep! 2) + (if (< num-available 2) + (begin + (server:try-running run-id))) + (thread-sleep! 10) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) + +;; keep this as a function to ease future +(define (client:start run-id server-info) + (http-transport:client-connect (tasks:hostinfo-get-interface server-info) + (tasks:hostinfo-get-port server-info))) ;; client:signal-handler (define (client:signal-handler signum) + (signal-mask! signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () "") ;; do nothing for now (was flush out last call if applicable) @@ -107,13 +144,16 @@ (thread-start! th2) (thread-start! th1) (thread-join! th2)))) ;; client:launch -(define (client:launch) +;; Need to set the signal handler somewhere other than here as this +;; routine will go away. +;; +(define (client:launch run-id) (set-signal-handler! signal/int client:signal-handler) - (if (client:setup) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) + (if (client:setup run-id) + (debug:print-info 2 "connected as client") + (begin + (debug:print 0 "ERROR: Failed to connect as client") + (exit)))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml) +(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3) (require-extension sqlite3 regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -23,40 +23,66 @@ ;; (require-library margs) ;; (include "margs.scm") (define getenv get-environment-variable) +(define (safe-setenv key val) + (if (and (string? val)(string? key)) + (handle-exceptions + exn + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val) + (setenv key val)) + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) -;; global gletches +;; GLOBAL GLETCHES (define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar +(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) +(define *alt-log-file* #f) ;; used by -log +(define *common:denoise* (make-hash-table)) ;; for low noise printing + +;; DATABASE +(define *dbstruct-db* #f) +(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > +(define *db-stats-mutex* (make-mutex)) +(define *db-sync-mutex* (make-mutex)) +(define *db-multi-sync-mutex* (make-mutex)) +(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db +(define *megatest-db* #f) +(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *db-write-access* #t) +(define *inmemdb* #f) +(define *task-db* #f) ;; (vector db path-to-db) +(define *db-access-allowed* #t) ;; flag to allow access +(define *db-access-mutex* (make-mutex)) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* #f) -(define *megatest-db* #f) +(define *transport-type* 'http) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port -(define *runremote* #f) ;; if set up for server communication this will hold -(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) (define *server-info* #f) (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) +(define *server-run* #t) +(define *run-id* #f) +(define *server-kind-run* (make-hash-table)) (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here @@ -68,10 +94,18 @@ ;; Awful. Please FIXME (define *env-vars-by-run-id* (make-hash-table)) (define *current-run-name* #f) +;; Testconfig and runconfig caches. +(define *testconfigs* (make-hash-table)) ;; test-name => testconfig +(define *runconfigs* (make-hash-table)) ;; target => runconfig + +;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than +;; five seconds ago +(define *pre-reqs-met-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -80,11 +114,95 @@ (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) -;; Debugging stuff +;; Generic string database +(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) +;; Generic path database +(define *fdb* #f) + +;;====================================================================== +;; L O C K E R S A N D B L O C K E R S +;;====================================================================== + +;; block further accesses to databases. Call this before shutting db down +(define (common:db-block-further-queries) + (mutex-lock! *db-access-mutex*) + (set! *db-access-allowed* #f) + (mutex-unlock! *db-access-mutex*)) + +(define (common:db-access-allowed?) + (let ((val (begin + (mutex-lock! *db-access-mutex*) + *db-access-allowed* + (mutex-unlock! *db-access-mutex*)))) + val)) + +;;====================================================================== +;; U S E F U L S T U F F +;;====================================================================== + +(define (common:low-noise-print waitval . keys) + (let* ((key (string-intersperse (map conc keys) "-" )) + (lasttime (hash-table-ref/default *common:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *common:denoise* key currtime) + #t) + #f))) + +(define (common:get-megatest-exe) + (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")) + +(define (common:read-encoded-string instr) + (handle-exceptions + exn + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + #f) + (read (open-input-string (base64:base64-decode instr)))) + (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) + +;;====================================================================== +;; S T A T E S A N D S T A T U S E S +;;====================================================================== + +(define *common:std-states* + '((0 "COMPLETED") + (1 "NOT_STARTED") + (2 "RUNNING") + (3 "REMOTEHOSTSTART") + (4 "LAUNCHED") + (5 "KILLED") + (6 "KILLREQ") + (7 "STUCK"))) + +(define *common:std-statuses* + '((0 "PASS") + (1 "WARN") + (2 "FAIL") + (3 "CHECK") + (4 "n/a") + (5 "WAIVED") + (6 "SKIP") + (7 "DELETED") + (8 "STUCK/DEAD") + (9 "ABORT"))) + +;; These are stopping conditions that prevent a test from being run +(define *common:cant-run-states-sym* + '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT)) + +;;====================================================================== +;; D E B U G G I N G S T U F F +;;====================================================================== + (define *verbosity* 1) (define *logging* #f) (define (get-with-default val default) (let ((val (args:get-arg val))) @@ -92,14 +210,77 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) +(define (common:get-testsuite-name) + (or (configf:lookup *configdat* "setup" "testsuite" ) + (pathname-file *toppath*))) + +;;====================================================================== +;; E X I T H A N D L I N G +;;====================================================================== + +(define (std-exit-procedure) + (debug:print-info 2 "starting exit process, finalizing databases.") + (rmt:print-db-stats) + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (and (not (null? run-ids)) + (configf:lookup *configdat* "setup" "megatest-db")) + (db:multi-db-sync run-ids 'new2old))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) + +(define (std-signal-handler signum) + (signal-mask! signum) + (debug:print 0 "ERROR: Received signal " signum " exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(set-signal-handler! signal/int std-signal-handler) +(set-signal-handler! signal/term std-signal-handler) + ;;====================================================================== ;; Misc utils ;;====================================================================== +;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 +(define (common:hms-string->seconds tstr) + (let ((parts (string-split tstr)) + (time-secs 0) + ;; s=seconds, m=minutes, h=hours, d=days + (trx (regexp "(\\d+)([smhd])"))) + (for-each (lambda (part) + (let ((match (string-match trx part))) + (if match + (let ((val (string->number (cadr match))) + (unt (caddr match))) + (if val + (set! time-secs (+ time-secs (* val + (case (string->symbol unt) + ((s) 1) + ((m) 60) + ((h) (* 60 60)) + ((d) (* 24 60 60)) + (else 0)))))))))) + parts) + time-secs)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + ;; one-of args defined (define (args-defined? . param) (let ((res #f)) (for-each (lambda (arg) @@ -132,20 +313,128 @@ (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) -(define (common:get-runconfig-targets) +(define (common:get-runconfig-targets #!key (configf #f)) (sort (map car (hash-table->alist - (read-config "runconfigs.config" - #f #t))) string (length lista)(length listb)) + #f + (let loop ((heda (car lista)) + (tala (cdr lista)) + (hedb (car listb)) + (talb (cdr listb))) + (if (equal? heda hedb) + (if (null? tala) ;; we are done + talb + (loop (car tala) + (cdr tala) + (car talb) + (cdr talb))) + #f))))) + +;; Needed for long lists to be sorted where (apply max ... ) dies +;; +(define (common:max inlst) + (let loop ((max-val (car inlst)) + (hed (car inlst)) + (tal (cdr inlst))) + (if (not (null? tal)) + (loop (max hed max-val) + (car tal) + (cdr tal)) + (max hed max-val)))) + + +;;====================================================================== +;; Munge data into nice forms +;;====================================================================== + +;; Generate an index for a sparse list of key values +;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) +;; +;; => +;; +;; ( (rowname1 0)(rowname2 1)) ;; rownames -> num +;; (colname1 0)(colname2 1)) ) ;; colnames -> num +;; +;; optional apply proc to rownum colnum value +(define (common:sparse-list-generate-index data #!key (proc #f)) + (if (null? data) + (list '() '()) + (let loop ((hed (car data)) + (tal (cdr data)) + (rownames '()) + (colnames '()) + (rownum 0) + (colnum 0)) + (let* ((rowkey (car hed)) + (colkey (cadr hed)) + (value (caddr hed)) + (existing-rowdat (assoc rowkey rownames)) + (existing-coldat (assoc colkey colnames)) + (curr-rownum (if existing-rowdat rownum (+ rownum 1))) + (curr-colnum (if existing-coldat colnum (+ colnum 1))) + (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) + (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) + ;; (debug:print-info 0 "Processing record: " hed ) + (if proc (proc curr-rownum curr-colnum rowkey colkey value)) + (if (null? tal) + (list new-rownames new-colnames) + (loop (car tal) + (cdr tal) + new-rownames + new-colnames + (if (> curr-rownum rownum) curr-rownum rownum) + (if (> curr-colnum colnum) curr-colnum colnum) + )))))) ;;====================================================================== ;; System stuff ;;====================================================================== @@ -168,45 +457,94 @@ (set! freespc newval)))))) (car df-results)) freespc)) (define (get-cpu-load) - (let* ((load-res (cmd-run->list "uptime")) - (load-rx (regexp "load average:\\s+(\\d+)")) - (cpu-load #f)) - (for-each (lambda (l) - (let ((match (string-search load-rx l))) - (if match - (let ((newval (string->number (cadr match)))) - (if (number? newval) - (set! cpu-load newval)))))) - (car load-res)) - cpu-load)) + (car (common:get-cpu-load))) +;; (let* ((load-res (cmd-run->list "uptime")) +;; (load-rx (regexp "load average:\\s+(\\d+)")) +;; (cpu-load #f)) +;; (for-each (lambda (l) +;; (let ((match (string-search load-rx l))) +;; (if match +;; (let ((newval (string->number (cadr match)))) +;; (if (number? newval) +;; (set! cpu-load newval)))))) +;; (car load-res)) +;; cpu-load)) + +;; get cpu load by reading from /proc/loadavg, return all three values +;; +(define (common:get-cpu-load) + (with-input-from-file "/proc/loadavg" + (lambda ()(list (read)(read)(read))))) + +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000)) + (let* ((loadavg (common:get-cpu-load)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjload (* maxload numcpus)) + (loadjmp (- first next))) + (cond + ((and (> first adjload) + (> count 0)) + (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + ((and (> loadjmp numcpus) + (> count 0)) + (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) + +(define (common:get-num-cpus) + (with-input-from-file "/proc/cpuinfo" + (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + numcpu + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line))))))) (define (get-uname . params) (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) -(define (save-environment-as-files fname) +(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () - (for-each (lambda (key) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "setenv " (car key) " " sval))) - envvars))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (member key ignorevars) + "# setenv " + "setenv ") + key " " delim val delim))) + envvars))) (with-output-to-file (conc fname ".sh") (lambda () - (for-each (lambda (key) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "export " (car key) "=" sval))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (member key ignorevars) + "# export " + "export ") + key "=" delim val delim))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) @@ -237,10 +575,37 @@ sec "s"))) (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) + +(define (seconds->work-week/day-time sec) + (time->string + (seconds->local-time sec) "ww%V.%u %H:%M")) + +(define (seconds->work-week/day sec) + (time->string + (seconds->local-time sec) "ww%V.%u")) + +(define (seconds->year-work-week/day sec) + (time->string + (seconds->local-time sec) "%yww%V.%w")) + +(define (seconds->year-work-week/day-time sec) + (time->string + (seconds->local-time sec) "%yww%V.%w %H:%M")) + +(define (seconds->quarter sec) + (case (string->number + (time->string + (seconds->local-time sec) + "%m")) + ((1 2 3) 1) + ((4 5 6) 2) + ((7 8 9) 3) + ((10 11 12) 4) + (else #f))) ;;====================================================================== ;; Colors ;;====================================================================== @@ -249,31 +614,32 @@ ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") ((purple) "This is unfinished ..."))) -(define (common:get-color-for-state-status state status) - (case (string->symbol state) - ((COMPLETED) - (case (string->symbol status) - ((PASS) "70 249 73") - ((WARN WAIVED) "255 172 13") - ((SKIP) "230 230 0") - (else "223 33 49"))) - ((LAUNCHED) "101 123 142") - ((CHECK) "255 100 50") - ((REMOTEHOSTSTART) "50 130 195") - ((RUNNING) "9 131 232") - ((KILLREQ) "39 82 206") - ((KILLED) "234 101 17") - ((NOT_STARTED) "240 240 240") - (else "192 192 192"))) +;; (define (common:get-color-for-state-status state status) +;; (case (string->symbol state) +;; ((COMPLETED) +;; (case (string->symbol status) +;; ((PASS) "70 249 73") +;; ((WARN WAIVED) "255 172 13") +;; ((SKIP) "230 230 0") +;; (else "223 33 49"))) +;; ((LAUNCHED) "101 123 142") +;; ((CHECK) "255 100 50") +;; ((REMOTEHOSTSTART) "50 130 195") +;; ((RUNNING) "9 131 232") +;; ((KILLREQ) "39 82 206") +;; ((KILLED) "234 101 17") +;; ((NOT_STARTED) "240 240 240") +;; (else "192 192 192"))) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") + ((equal? status "ABORT") "brown") (else "black"))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -7,27 +7,51 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== +;; (use trace) + +;; Some of these routines use: +;; +;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html +;; +;; Syntax for defining macros in a simple style similar to function definiton, +;; when there is a single pattern for the argument list and there are no keywords. +;; +;; (define-simple-syntax (name arg ...) body ...) +;; + +(define-syntax define-simple-syntax + (syntax-rules () + ((_ (name arg ...) body ...) + (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) + +(define-syntax common:handle-exceptions + (syntax-rules () + ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + (define (debug:calc-verbosity vstr) (cond - (vstr - (let ((debugvals (string-split vstr ","))) - (if (> (length debugvals) 1) - (map string->number debugvals) - (string->number (car debugvals))))) - ((args:get-arg "-v") 2) + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) (begin - (print "ERROR: Invalid debug value " vstr) + (print "ERROR: Invalid debug value \"" vstr "\"") #f) #t)) (define (debug:debug-mode n) (or (and (number? *verbosity*) @@ -38,10 +62,12 @@ (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (getenv "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr)) (debug:check-verbosity *verbosity* debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not *verbosity*)(set! *verbosity* 1)) (if (or (args:get-arg "-debug") (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) @@ -49,21 +75,27 @@ (define (debug:print n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () - (apply print params) - (if *logging* (apply db:log-event params)))))) + (if *logging* + (db:log-event (apply conc params)) + ;; (apply print "pid:" (current-process-id) " " params) + (apply print params) + ))))) (define (debug:print-info n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () - (let ((res #f));; (format#format #f "INFO:~2d ~a" n (apply conc params)))) - (apply print "INFO: (" n ") " params) ;; res) - (if *logging* (db:log-event res))))))) + (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params)))) + (if *logging* + (db:log-event res) + ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) + (apply print "INFO: (" n ") " params) ;; res) + )))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -54,17 +54,18 @@ (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) +(define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs -(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get)\\s+([^\\}\\{]*)\\}(.*)")) -(define (configf:process-line l ht) +(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) +(define (configf:process-line l ht allow-system) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) @@ -81,16 +82,19 @@ (let* ((parts (string-split cmd)) (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) - (with-input-from-string fullcmd - (lambda () - (set! result ((eval (read)) ht)))) - (loop (conc prestr result poststr))) + (if (or allow-system + (not (member cmdtype '("system" "shell")))) + (with-input-from-string fullcmd + (lambda () + (set! result ((eval (read)) ht)))) + (set! result (conc "#{(" cmdtype ") " cmd "}"))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) @@ -103,25 +107,44 @@ "\n"))) (debug:print-info 4 "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) - (print "ERROR: " cmd " returned bad exit code " status)) + (lambda () + (print "ERROR: " cmd " returned bad exit code " status))) "")))) ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) - (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) + (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ - (config-lookup config targ var) - #f))) - -(define-inline (configf:read-line p ht allow-processing) - (if (and allow-processing - (not (eq? allow-processing 'return-string))) - (configf:process-line (read-line p) ht) - (read-line p))) + (or (configf:lookup config targ var) + (configf:lookup config "default" var)) + (configf:lookup config "default" var)))) + +;; 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) + (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)))) + (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))))))) ;; 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) @@ -131,11 +154,12 @@ (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (if (not (file-exists? path)) (begin (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) - (if (not ht)(make-hash-table) ht)) + ;; 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 (open-input-file path)) (res (if (not ht)(make-hash-table) ht))) (let loop ((inl (configf:read-line inp res allow-system)) ;; (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 @@ -189,30 +213,31 @@ (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist - key + key (case allow-system ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))))) (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (config:eval-string-in-environment val) - val))) - (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar - (begin - ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) - (setenv key realval))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval)) - (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval)) + (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key #t)) + (loop (configf:read-line inp res allow-system) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" @@ -253,18 +278,19 @@ #f)) )) #f)) (define configf:lookup config-lookup) +(define configf:read-file read-config) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat)))) -(define (configf:get-section cfdat section) +(define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (setup) (let* ((configf (find-config)) (config (if configf (read-config configf #f #t) #f))) @@ -323,11 +349,11 @@ (res '())) (if (eof-object? inl) (begin (close-input-port inp) (reverse res)) - (loop (read-line inp)(cons inl))))) + (loop (read-line inp)(cons inl res))))) '())) ;;====================================================================== ;; Write a config ;; 0. Given a refererence data structure "indat" @@ -411,5 +437,58 @@ (for-each (lambda (line) (print line)) (configf:expand-multi-lines fdat)))))) +;;====================================================================== +;; 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 (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)))))) + sheets) + (list data "NO ERRORS")))))) + +;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val +;; +(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) + (for-each + (lambda (sheetname) + (let* ((sheettmp (assoc sheetname data)) + (sheetdat (if sheettmp (cadr sheettmp) '()))) + (if initproc1 (initproc1 sheetname)) + (for-each + (lambda (sectionname) + (let* ((sectiontmp (assoc sectionname sheetdat)) + (sectiondat (if sectiontmp (cadr sectiontmp) '()))) + (if initproc2 (initproc2 sheetname sectionname)) + (for-each + (lambda (varname) + (let* ((valtmp (assoc varname sectiondat)) + (val (if valtmp (cadr valtmp) ""))) + (proc sheetname sectionname varname val))) + (map car sectiondat)))) + (map car sheetdat)))) + (map car data))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -23,14 +23,34 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) +(declare (uses gutils)) +(declare (uses rmt)) +(declare (uses ezsteps)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") + +;;====================================================================== +;; C O M M O N +;;====================================================================== + +(define *dashboard-comment-share-slot* #f) + +(define (dtests:get-pre-command #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) + +(define (dtests:get-post-command #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" @@ -41,11 +61,12 @@ (list "Testname: " "Item path: " "Current state: " "Current status: " "Test comment: " - "Test id: ")) + "Test id: " + "Test date: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") @@ -62,24 +83,36 @@ (lambda (testdat) (let ((newstatus (db:test-get-status testdat)) (oldstatus (iup:attribute lbl "TITLE"))) (if (not (equal? oldstatus newstatus)) (begin - (iup:attribute-set! lbl "FGCOLOR" (common:get-color-for-state-status (db:test-get-state testdat) - (db:test-get-status testdat))) + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") (lambda (testdat) - (db:test-get-comment testdat))) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-slot* + "VALUE" + newcomment))) + newcomment))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) ))))) ;;====================================================================== ;; Test meta panel ;;====================================================================== @@ -97,12 +130,11 @@ )) (list "Author: " "Owner: " "Reviewed: " "Tags: " - "Description: " - )) + "Description: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-meta "author" (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") @@ -124,27 +156,35 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== -(define (run-info-panel keydat testdat runname) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " ") ; #:expand "HORIZONTAL" - )) - keydat) - (list (iup:label "runname ")(iup:label "run-id")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc (db:test-get-run_id testdat))) - (iup:label "" #:expand "VERTICAL"))))))) +(define (run-info-panel db keydat testdat runname) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (db:get-run-info db run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) ;;====================================================================== ;; Host info panel ;;====================================================================== (define (host-info-panel testdat store-label) @@ -158,70 +198,87 @@ (list "Hostname: " "Uname -a: " "Disk free: " "CPU Load: " "Run duration: " - "Logfile: ")) + "Logfile: " + "Top process id: ")) (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" - (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL") + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-host testdat))) (store-label "Uname" (iup:label " " #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-uname testdat))) + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) (store-label "DiskFree" (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-cpuload testdat)))) (store-label "RunDuration" (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) - (store-label "CPULoad" + (store-label "LogFile" (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-final_logf testdat))))))))) + (lambda (testdat)(conc (db:test-get-final_logf testdat)))) + (store-label "ProcessId" + (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-process_id testdat)))) + ))))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat)) - (color (common:get-color-for-state-status state status))) + (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) +(define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) + ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel test-id testdat) +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) - (newstate #f)) + (newstate #f) + (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") - (iup:textbox #:action (lambda (val a b) - (open-run-close db:test-set-state-status-by-id #f test-id #f #f b) - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL")) + (let ((txtbox (iup:textbox #:action (lambda (val a b) + (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id state #f #f) + (rmt:test-set-state-status-by-id run-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) - (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) + (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) @@ -234,14 +291,27 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id #f status #f) - (db:test-set-status! testdat status))))) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver run-id testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) + (begin + (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (db:test-set-status! testdat status)))))))) btn)) - (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) @@ -249,38 +319,120 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) +(define (dashboard-tests:run-html-viewer lfilename) + (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) + (if htmlviewercmd + (system (conc "(" htmlviewercmd " " lfilename " ) &")) + (iup:send-url lfilename)))) + +(define (dashboard-tests:run-a-step info) + #t) + +(define (dashboard-tests:step-run-control testdat stepname testconfig) + (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title stepname + (iup:vbox ; #:expand "YES" + (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) + (iup:button "Re-run" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (thread-start! + (make-thread (lambda () + (ezsteps:run-from testdat stepname #t)) + (conc "ezstep run single step " stepname))))) + (iup:button "Re-run and continue" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (thread-start! + (make-thread (lambda () + (ezsteps:run-from testdat stepname #f)) + (conc "ezstep run from step " stepname))))) + ;; (iup:button "Refresh test data" + ;; #:expand "HORIZONTAL" + ;; #:action (lambda (obj) + ;; (print "Refresh test data " stepname)) + ))) + +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) + (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) + (wregx (if (string? wpatt)(regexp wpatt) #f)) + (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) + (comnt (iup:textbox #:action (lambda (val a b) + (if wpatt + (if (string-match wregx b) + (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) + (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) + ))) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:expand "HORIZONTAL")) + (dlog #f)) + (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title "SET WAIVER" + (iup:vbox ; #:expand "YES" + (iup:label (conc "Enter justification for waiving test " + (db:test-get-testname testdat) + (if (equal? (db:test-get-item-path testdat) "") + "" + (conc "/" (db:test-get-item-path testdat))))) + wmesg ;; the informational msg on whether it matches + comnt + (iup:hbox + (iup:button "Apply and Close " + #:expand "HORIZONTAL" + #:action (lambda (obj) + (let ((comment (iup:attribute comnt "VALUE")) + (test-id (db:test-get-id testdat))) + (if (or (not wpatt) + (string-match wregx comment)) + (begin + (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (db:test-set-status! testdat "WAIVED") + (cmtcmd comment) + (iup:destroy! dlog)))))) + (iup:button "Cancel" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (iup:destroy! dlog))))))) + dlog)) + ;;====================================================================== ;; ;;====================================================================== -(define (examine-test test-id) ;; run-id run-key origtest) - (let* ((testdat (open-run-close db:get-test-info-by-id #f test-id)) - (db-path (conc *toppath* "/megatest.db")) +(define (examine-test run-id test-id) ;; run-id run-key origtest) + (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct (make-dbr:dbstruct path: (configf:lookup *configdat* "setup" "linktree") local: #t)) + (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) - (request-update #t) - (db #f)) + (request-update #t)) (if (not testdat) (begin - (debug:print 0 "ERROR: No test data found for test " test-id ", exiting") + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) - (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) - (keydat (if testdat (open-run-close db:get-key-val-pairs #f run-id) #f)) - (rundat (if testdat (open-run-close db:get-run-info #f run-id) #f)) - (runname (if testdat (db:get-value-by-header (db:get-row rundat) + (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) + (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) + (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) - (teststeps (if testdat (db:get-compressed-steps test-id) '())) + (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + ;; These next two are intentional bad values to ensure errors if they should not + ;; get filled in properly. (logfile "/this/dir/better/not/exist") - (rundir logfile) + (rundir (if testdat + (db:test-get-rundir testdat) + logfile)) + (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found + (teststeps (if testdat (dcommon:get-compressed-steps dbstruct run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat - (let ((tm (open-run-close db:testmeta-get-record #f testname))) + (let ((tm (db:testmeta-get-record dbstruct testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -290,38 +442,79 @@ "/")) (item-path (db:test-get-item-path testdat)) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (iup:send-url logfile) + (dashboard-tests:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) + (view-a-log (lambda (lfile) + (let ((lfilename (conc rundir "/" lfile))) + ;; (print "lfilename: " lfilename) + (if (file-exists? lfilename) + ;(system (conc "firefox " logfile "&")) + (dashboard-tests:run-html-viewer lfilename) + (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir - ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) - (need-update (or (and (> curr-mod-time db-mod-time) - (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched + (let* ((curr-mod-time (max (file-modification-time db-path) + (if (file-exists? testdat-path) + (file-modification-time testdat-path) + (begin + (set! testdat-path (conc rundir "/testdat.db")) + 0)))) + (need-update (or (and (>= curr-mod-time db-mod-time) + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) - (newtestdat (if need-update (open-run-close db:get-test-info-by-id #f test-id)))) + (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler + (handle-exceptions + exn + (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) + (db:get-test-info-by-id dbstruct run-id test-id ))))) + ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (db:get-compressed-steps test-id)) + (set! teststeps (dcommon:get-compressed-steps dbstruct run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (set! rundir (db:test-get-rundir testdat)) + (set! rundir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) + (set! db-mod-time curr-mod-time)) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) - (widgets (make-hash-table)) + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) (meta-widgets (make-hash-table)) (self #f) (store-label (lambda (name lbl cmd) (hash-table-set! widgets name (lambda (testdat) @@ -347,28 +540,60 @@ ))))) lbl)) (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) - (let ((cmd (iup:attribute command-text-box "VALUE"))) - (system (conc cmd " &")))))) + (let* ((cmd (iup:attribute command-text-box "VALUE")) + (fullcmd (conc (dtests:get-pre-command) + cmd + (dtests:get-post-command)))) + (debug:print-info 02 "Running command: " fullcmd) + (system fullcmd))))) + (kill-jobs (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -set-state-status KILLREQ,n/a -testpatt %/% " + " -state RUNNING")))) (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" - (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname + (conc "megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) - ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + )))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (clean-run-execute (lambda (x) + (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";megatest -target " keystring " -runname " runname + " -runtests " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ))) + (system (conc (dtests:get-pre-command) + cmd + (dtests:get-post-command)))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" - (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname + (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) - " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))) + " -v")) + ))) (cond ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) @@ -376,27 +601,29 @@ (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" - (run-info-panel keydat testdat runname) + (run-info-panel dbstruct keydat testdat runname) (test-info-panel testdat store-label widgets) (test-meta-panel testmeta store-meta)) (host-info-panel testdat store-label) ;; The controls (iup:frame #:title "Actions" (iup:vbox (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x") - (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) (apply iup:hbox (list command-text-box command-launch-button)))) - (set-fields-panel test-id testdat) + (set-fields-panel dbstruct run-id test-id testdat) (let ((tabs (iup:tabs ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" @@ -405,15 +632,20 @@ #:numcol 6 #:numlin 30 #:numcol-visible 6 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) - (if (equal? col 6) - (let ((fname (iup:attribute obj (conc lin ":" col)))) - (viewlog fname) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) - )) + ;; (if (equal? col 6) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc))) ;; col)))) + (if (eq? col 6) + (view-a-log fname) + (iup:show + (dashboard-tests:step-run-control + testdat + (iup:attribute obj (conc lin ":" 1)) + teststeps)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) ;; (if (< count 30) ;; (loop (+ count 1)))) (iup:attribute-set! steps-matrix "0:1" "Step Name") @@ -427,21 +659,11 @@ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) - (if (not (null? teststeps)) - (let loop ((hed (car teststeps)) - (tal (cdr teststeps)) - (rownum 1) - (colnum 1)) - (let ((val (vector-ref hed (- colnum 1)))) - (iup:attribute-set! steps-matrix (conc rownum ":" colnum)(if val (conc val) "")) - (if (< colnum 6) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1))))))))) + (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame @@ -471,30 +693,24 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (open-run-close db:read-test-data #f test-id "%"))) + (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) - test-data))))) + test-data)) + ;;(dashboard:run-controls) + ))) (iup:attribute-set! tabs "TABTITLE0" "Steps") (iup:attribute-set! tabs "TABTITLE1" "Test Data") tabs)))) (iup:show self) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat) - ; (iup:refresh self) (if *exit-started* (set! *exit-started* 'ok)))))))))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -12,10 +12,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) +(import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (uses common)) @@ -27,27 +28,32 @@ (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) +(declare (uses tree)) +(declare (uses dcommon)) + ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) +(declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2011 + license GPL, Copyright (C) Matt Welland 2012-2014 Usage: dashboard [options] - -h : this help - -server host:port : connect to host:port instead of db access - -test testid : control test identified by testid - -guimonitor : control panel for runs + -h : this help + -server host:port : connect to host:port instead of db access + -test run-id,test-id : control test identified by testid + -guimonitor : control panel for runs Misc -rows N : set number of rows ")) @@ -57,10 +63,11 @@ (list "-rows" "-run" "-test" "-debug" "-host" + "-transport" ) (list "-h" "-use-server" "-guimonitor" "-main" @@ -73,65 +80,98 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (setup-for-run)) +(if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* #f) ;; (open-db)) - -(if (args:get-arg "-host") - (begin - (set! *runremote* (string-split (args:get-arg "-host" ":"))) - (client:launch)) - (if (not (args:get-arg "-use-server")) - (set! *transport-type* 'fs) ;; force fs access - (client:launch))) +(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* + local: #t)) +(define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. -(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) -;; (client:setup *db*) +(define *read-only* (not (file-read-access? *db-file-path*))) (define toplevel #f) (define dlg #f) (define max-test-num 0) -;; (define *keys* (open-run-close db:get-keys #f)) -(define *keys* (cdb:remote-run db:get-keys #f)) -;; (define *keys* (db:get-keys *db*)) -(define *dbkeys* (map (lambda (x)(vector-ref x 0)) - (append *keys* (list (vector "runname" "blah"))))) +(define *keys* (db:get-keys *dbstruct-local*)) + +(define *dbkeys* (append *keys* (list "runname"))) + (define *header* #f) (define *allruns* '()) (define *allruns-by-id* (make-hash-table)) ;; (define *runchangerate* (make-hash-table)) (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) -;; (define *tot-run-count* (db:get-num-runs *db* "%")) +(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) +;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) + +;; Update management +;; (define *last-update* (current-seconds)) +(define *last-db-update-time* 0) +(define *please-update-buttons* #t) +(define *delayed-update* 0) +(define *update-is-running* #f) +(define *update-mutex* (make-mutex)) + +(define *all-item-test-names* '()) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) (define *examine-test-dat* (make-hash-table)) (define *exit-started* #f) (define *status-ignore-hash* (make-hash-table)) (define *state-ignore-hash* (make-hash-table)) -(define *last-db-update-time* 0) -(define *please-update-buttons* #t) -(define *delayed-update* 0) +(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") + (vector "Sort -a" 'testname "DESC") + (vector "Sort +t" 'event_time "ASC") + (vector "Sort -t" 'event_time "DESC") + (vector "Sort +s" 'statestatus "ASC") + (vector "Sort -s" 'statestatus "DESC") + (vector "Sort +a" 'testname "ASC"))) + +(define *tests-sort-type-index* '(("+testname" 0) + ("-testname" 1) + ("+event_time" 2) + ("-event_time" 3) + ("+statestatus" 4) + ("-statestatus" 5))) + +;; Don't forget to adjust the >= below if you add to the sort-options above +(define (next-sort-option) + (if (>= *tests-sort-reverse* 5) + (set! *tests-sort-reverse* 0) + (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) + *tests-sort-reverse*) + +(define *tests-sort-reverse* + (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) + (if t-sort + (cadr t-sort) + 3))) -(define *db-file-path* (conc *toppath* "/megatest.db")) +(define (get-curr-sort) + (vector-ref *tests-sort-options* *tests-sort-reverse*)) -(define *tests-sort-reverse* #f) (define *hide-empty-runs* #f) +(define *hide-not-hide* #t) ;; toggle for hide/not hide +(define *hide-not-hide-button* #f) +(define *hide-not-hide-tabs* #f) + +(define *current-tab-number* 0) +(define *updaters* (make-hash-table)) (debug:setup) (define uidat #f) @@ -138,106 +178,90 @@ (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) (define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) +(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) (define (message-window msg) (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) -(define (iuplistbox-fill-list lb items . default) - (let ((i 1) - (selected-item (if (null? default) #f (car default)))) - (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) (for-each (lambda (item) (iup:attribute-set! lb (number->string i) item) (if selected-item (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) (set! i (+ i 1))) items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) i)) (define (pad-list l n)(append l (make-list (- n (length l))))) (define (colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let ((modtime (file-modification-time *db-file-path*)) - (referenced-run-ids '())) - (if (or (and (> modtime *last-db-update-time*) - (> (current-seconds)(+ *last-db-update-time* 5))) - (> *delayed-update* 0)) - ;; - ;; Run this stuff only when the megatest.db file has changed - ;; - (let ((full-run (> (random 100) 75))) ;; 25% of the time do a full refresh - (debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts) - (set! *please-update-buttons* #t) - (set! *last-db-update-time* modtime) - (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts)) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*))) - ;; (thread-sleep! 0.1) ;; give some time to other threads - (debug:print 6 "update-rundat, got " (length runs) " runs") - (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes - (begin - (set! *last-update* (current-seconds)) - (set! *tot-run-count* (length runs)))) - ;; - ;; trim runs to only those that are changing often here - - ;; - (for-each (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses))) - (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (cdb:remote-run db:get-key-vals #f run-id))) - ;; Not sure this is needed? - (set! referenced-run-ids (cons run-id referenced-run-ids)) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals))) - ;; - ;; compare the tests with the tests in *allruns-by-id* same run-id - ;; if different then increment value in *runchangerate* - ;; - (hash-table-set! *allruns-by-id* run-id dstruct) - (set! result (cons dstruct result)))))) - runs) - - ;; - ;; if full-run use referenced-run-ids to delete data in *all-runs-by-id* and *runchangerate* - ;; - - (set! *header* header) - (set! *allruns* result) - (debug:print 6 "*allruns* has " (length *allruns*) " runs") - ;; (set! *tot-run-count* (+ 1 (length *allruns*))) - maxtests)) - ;; - ;; Run this if the megatest.db file did not get touched - ;; - (begin - - *num-tests*)))) ;; FIXME, naughty coding eh? + (let* ((referenced-run-ids '()) + (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + *start-run-offset* keypatts)) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0) + (states (hash-table-keys *state-ignore-hash*)) + (statuses (hash-table-keys *status-ignore-hash*)) + (sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath))) + ;; + ;; trim runs to only those that are changing often here + ;; + (for-each (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses + #f #f + *hide-not-hide* + sort-by + sort-order + 'shortlist)) + ;; NOTE: bubble-up also sets the global *all-item-test-names* + ;; (tests (bubble-up tmptests priority: bubble-type)) + (key-vals (db:get-key-vals *dbstruct-local* run-id))) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (set! referenced-run-ids (cons run-id referenced-run-ids)) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set + (not (null? tests))) + (let ((dstruct (vector run tests key-vals))) + ;; + ;; compare the tests with the tests in *allruns-by-id* same run-id + ;; if different then increment value in *runchangerate* + ;; + (hash-table-set! *allruns-by-id* run-id dstruct) + (set! result (cons dstruct result)))))) + runs) + + (set! *header* header) + (set! *allruns* result) + (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") + maxtests)) (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) @@ -265,36 +289,35 @@ (vector-set! res 1 (car (string-split (cadr splst) ")")))) res)) lst)) (define (collapse-rows inlst) - (let* ((newlst (filter (lambda (x) - (let* ((tparts (string-split x "(")) - (basetname (if (null? tparts) x (car tparts)))) + (let* ((sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) + (newlst (filter (lambda (x) + (let* ((tparts (string-split x "(")) + (basetname (if (null? tparts) x (car tparts)))) ;(print "x " x " tparts: " tparts " basetname: " basetname) - (cond - ((string-match blank-line-rx x) #f) - ((equal? x basetname) #t) - ((hash-table-ref/default *collapsed* basetname #f) + (cond + ((string-match blank-line-rx x) #f) + ((equal? x basetname) #t) + ((hash-table-ref/default *collapsed* basetname #f) ;(print "Removing " basetname " from items") - #f) - (else #t)))) - inlst)) - (vlst (run-item-name->vectors newlst)) - ;; sort by second field - (vlst-s1 (sort vlst (lambda (a b) - (let ((astr (vector-ref a 1)) - (bstr (vector-ref b 1))) - (if (string=? astr "") #f #t))))) - ;; (>= (string-length (vector-ref a 1))(string-length (vector-ref b 1)))))) - (vlst-s2 (sort vlst-s1 (lambda (a b) - (string>= (vector-ref a 0)(vector-ref b 0)))))) + #f) + (else #t)))) + inlst)) + (vlst (run-item-name->vectors newlst)) + (vlst2 (bubble-up vlst priority: bubble-type))) (map (lambda (x) (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) - vlst-s2))) + vlst2))) (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) @@ -318,118 +341,849 @@ (iup:attribute-set! lbl "TITLE" munged-val))) (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) +;; +(define (get-itemized-tests test-dats) + (let ((tnames '())) + (for-each (lambda (tdat) + (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (if (not (equal? ipath "")) + (if (and (list? tnames) + (string? tname) + (not (member tname tnames))) + (set! tnames (append tnames (list tname))))))) + test-dats) + tnames)) + +;; Bubble up the top tests to above the items, collect the items underneath +;; all while preserving the sort order from the SQL query as best as possible. +;; +(define (bubble-up test-dats #!key (priority 'itempath)) + (if (null? test-dats) + test-dats + (begin + (let* ((tnames '()) ;; list of names used to reserve order + (tests (make-hash-table)) ;; hash of lists, used to build as we go + (itemized (get-itemized-tests test-dats))) + (for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (if (equal? ipath "") + ;; This a top level, prepend it + (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) + ;; This is item, append it + (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) + test-dats) + ;; Set all tests with items + (set! *all-item-test-names* (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + *all-item-test-names*)) + (let loop ((hed (car tnames)) + (tal (cdr tnames)) + (res '())) + (let ((newres (append res (hash-table-ref tests hed)))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))))) + (define (update-buttons uidat numruns numtests) - (if *please-update-buttons* - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) - (lftcol (dboard:uidat-get-lftcol uidat)) - (tableheader (dboard:uidat-get-header uidat)) - (table (dboard:uidat-get-runsvec uidat)) - (coln 0)) - (set! *please-update-buttons* #f) - (set! *alltestnamelst* '()) - ;; create a concise list of test names - (for-each - (lambda (rundat) - (if (vector? rundat) - (let* ((testdat (vector-ref rundat 1)) - (testnames (map test:test-get-fullname testdat))) - (if (not (and *hide-empty-runs* - (null? testnames))) - (for-each (lambda (testname) - (if (not (member testname *alltestnamelst*)) - (begin - (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) - testnames))))) - runs) - - (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) - '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) - (update-labels uidat) - (for-each - (lambda (rundat) - (if (not rundat) ;; handle padded runs - ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) - (let* ((run (vector-ref rundat 0)) - (testsdat (vector-ref rundat 1)) - (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) - (if x x ""))))) - (run-key (string-intersperse key-vals "\n"))) - - ;; fill in the run header key values - (let ((rown 0) - (headercol (vector-ref tableheader coln))) - (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) - (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) - (set! rown (+ rown 1)))) - key-vals)) - - ;; For this run now fill in the buttons for each test - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) - (if buttondat - (let* ((test (let ((matching (filter - (lambda (x)(equal? (test:test-get-fullname x) testname)) - testsdat))) - (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") - (car matching)))) - (testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test)) - (testfullname (test:test-get-fullname test)) - (teststatus (db:test-get-status test)) - (teststate (db:test-get-state test)) - (teststart (db:test-get-event_time test)) - (runtime (db:test-get-run_duration test)) - (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) - (button (vector-ref columndat rown)) - (color (common:get-color-for-state-status teststate teststatus)) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 test) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - *alltestnamelst*)) - (set! coln (+ coln 1)))) - runs)))) + (let* ((runs (if (> (length *allruns*) numruns) + (take-right *allruns* numruns) + (pad-list *allruns* numruns))) + (lftcol (dboard:uidat-get-lftcol uidat)) + (tableheader (dboard:uidat-get-header uidat)) + (table (dboard:uidat-get-runsvec uidat)) + (coln 0)) + (set! *alltestnamelst* '()) + ;; create a concise list of test names + (for-each + (lambda (rundat) + (if (vector? rundat) + (let* ((testdat (vector-ref rundat 1)) + (testnames (map test:test-get-fullname testdat))) + (if (not (and *hide-empty-runs* + (null? testnames))) + (for-each (lambda (testname) + (if (not (member testname *alltestnamelst*)) + (begin + (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) + testnames))))) + runs) + + (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) + (drop *alltestnamelst* *start-test-offset*) + '()))) + (append xl (make-list (- *num-tests* (length xl)) "")))) + (update-labels uidat) + (for-each + (lambda (rundat) + (if (not rundat) ;; handle padded runs + ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (let* ((run (vector-ref rundat 0)) + (testsdat (vector-ref rundat 1)) + (key-val-dat (vector-ref rundat 2)) + (run-id (db:get-value-by-header run *header* "id")) + (key-vals (append key-val-dat + (list (let ((x (db:get-value-by-header run *header* "runname"))) + (if x x ""))))) + (run-key (string-intersperse key-vals "\n"))) + + ;; fill in the run header key values + (let ((rown 0) + (headercol (vector-ref tableheader coln))) + (for-each (lambda (kval) + (let* ((labl (vector-ref headercol rown))) + (if (not (equal? kval (iup:attribute labl "TITLE"))) + (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (set! rown (+ rown 1)))) + key-vals)) + + ;; For this run now fill in the buttons for each test + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (if buttondat + (let* ((test (let ((matching (filter + (lambda (x)(equal? (test:test-get-fullname x) testname)) + testsdat))) + (if (null? matching) + (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (car matching)))) + (testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test)) + (testfullname (test:test-get-fullname test)) + (teststatus (db:test-get-status test)) + (teststate (db:test-get-state test)) + ;;(teststart (db:test-get-event_time test)) + ;;(runtime (db:test-get-run_duration test)) + (buttontxt (cond + ((equal? teststate "COMPLETED") teststatus) + ((and (equal? teststate "NOT_STARTED") + (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) + teststatus) + (else + teststate))) + (button (vector-ref columndat rown)) + (color (car (gutils:get-color-for-state-status teststate teststatus))) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (iup:attribute-set! button "BGCOLOR" color)) + (if (not (equal? curr-title buttontxt)) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 test) + (vector-set! buttondat 4 run-key))) + (set! rown (+ rown 1)))) + *alltestnamelst*)) + (set! coln (+ coln 1)))) + runs))) (define (mkstr . x) (string-intersperse (map conc x) ",")) + +(define (set-bg-on-filter) + (let ((search-changed (not (null? (filter (lambda (key) + (not (equal? (hash-table-ref *searchpatts* key) "%"))) + (hash-table-keys *searchpatts*))))) + (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) + (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) + (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" + (if (or search-changed + state-changed + status-changed) + "190 180 190" + "190 190 190" + )))) (define (update-search x val) - ;; (print "Setting search for " x " to " val) - (hash-table-set! *searchpatts* x val)) + (hash-table-set! *searchpatts* x val) + (set-bg-on-filter)) (define (mark-for-update) (set! *last-db-update-time* 0) - (set! *delayed-update* 1) - ) + (set! *delayed-update* 1)) + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; target populating logic +;; +;; lb = +;; field = target field name for this dropdown +;; referent-vals = selected value in the left dropdown +;; targets = list of targets to use to build the dropdown +;; +;; each node is chained: key1 -> key2 -> key3 +;; +;; must select values from only apropriate targets +;; a b c +;; a d e +;; a b f +;; a/b => c f +;; +(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) + ;; is the current value in the new list? choose new default if not + (let* ((remvalues (map (lambda (row) + (common:list-is-sublist referent-vals (vector->list row))) + targets)) + (values (delete-duplicates (map car (filter list? remvalues)))) + (sel-valnum (iup:attribute lb "VALUE")) + (sel-val (iup:attribute lb sel-valnum)) + (val-num 1)) + ;; first check if the current value is in the new list, otherwise replace with + ;; first value from values + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (for-each (lambda (val) + ;; (iup:attribute-set! lb "APPENDITEM" val) + (iup:attribute-set! lb (conc val-num) val) + (if (equal? sel-val val) + (iup:attribute-set! lb "VALUE" val-num)) + (set! val-num (+ val-num 1))) + values) + (let ((val (iup:attribute lb "VALUE"))) + (if val + val + (if (not (null? values)) + (let ((newval (car values))) + (iup:attribute-set! lb "VALUE" newval) + newval)))))) + +(define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) + (let* ((runconf-targs (common:get-runconfig-targets)) + (db-target-dat (db:get-targets *dbstruct-local*)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (all-targets (append db-targets + (map (lambda (x) + (list->vector + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header)))) + runconf-targs))) + (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) + (let loop ((key (car header)) + (remkeys (cdr header)) + (refvals '()) + (indx 0) + (lbs '())) + (let* ((lb (let ((lb (list-ref key-listboxes indx))) + (if lb + lb + (iup:listbox + #:size "45x50" + #:fontsize "10" + #:expand "YES" ;; "VERTICAL" + ;; #:dropdown "YES" + #:editbox "YES" + #:action (lambda (obj a b c) + (action-proc)) + #:caret_cb (lambda (obj a b c)(action-proc)) + )))) + ;; loop though all the targets and build the list for this dropdown + (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) + (if (null? remkeys) + ;; return a list of the listbox items and an iup:hbox with the labels and listboxes + (let ((listboxes (append lbs (list lb)))) + (list listboxes + (map (lambda (htxt lb) + (iup:vbox + (iup:label htxt) + lb)) + header + listboxes))) + (loop (car remkeys) + (cdr remkeys) + (append refvals (list selected-value)) + (+ indx 1) + (append lbs (list lb)))))))) + +;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string +;; interspersed with commas +;; +(define (dashboard:text-list-toggle-box items proc) + (let ((alltgls (make-hash-table))) + (apply iup:vbox + (map (lambda (item) + (iup:toggle + item + #:expand "YES" + #:action (lambda (obj tstate) + (if (eq? tstate 0) + (hash-table-delete! alltgls item) + (hash-table-set! alltgls item #t)) + (let ((all (hash-table-keys alltgls))) + (proc all))))) + items)))) + +;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command) + (let* ((cmd-tb (dboard:data-get-command-tb *data*)) + (cmd (dboard:data-get-command *data*)) + (test-patt (let ((tp (dboard:data-get-test-patts *data*))) + (if (equal? tp "") "%" tp))) + (states (dboard:data-get-states *data*)) + (statuses (dboard:data-get-statuses *data*)) + (target (let ((targ-list (dboard:data-get-target *data*))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:data-get-run-name *data*)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " :state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " :status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((runtests) + (set! full-cmd (conc full-cmd + " -runtests " + test-patt + " -target " + target + " -runname " + run-name + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 8) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) + (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + )) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:run-controls) + (let* ((targets (make-hash-table)) + (test-records (make-hash-table)) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (test-names (hash-table-keys all-tests-registry)) + (sorted-testnames #f) + (action "-runtests") + (cmdln "") + (runlogs (make-hash-table)) + (key-listboxes #f) + (updater-for-runs #f) + (update-keyvals (lambda () + (let ((targ (map (lambda (x) + (iup:attribute x "VALUE")) + (car (dashboard:update-target-selector key-listboxes))))) + (dboard:data-set-target! *data* targ) + (if updater-for-runs (updater-for-runs)) + (dashboard:update-run-command)))) + (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas + (test-patterns-textbox #f)) + (hash-table-set! tests-draw-state 'first-time #t) + (hash-table-set! tests-draw-state 'scalef 8) + (tests:get-full-data test-names test-records '() all-tests-registry) + (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) + + ;; refer to *keys*, *dbkeys* for keys + (iup:vbox + ;; The command line display/exectution control + (iup:frame + #:title "Command to be exectuted" + (iup:hbox + (iup:label "Run on" #:size "40x") + (iup:radio + (iup:hbox + (iup:toggle "Local" #:size "40x") + (iup:toggle "Server" #:size "40x"))) + (let ((tb (iup:textbox + #:value "megatest " + #:expand "HORIZONTAL" + #:readonly "YES" + #:font "Courier New, -12" + ))) + (dboard:data-set-command-tb! *data* tb) + tb) + (iup:button "Execute" #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc "xterm -geometry 180x20 -e \"" + (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") + ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))))) + + (iup:split + #:orientation "HORIZONTAL" + + (iup:split + #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:vbox + ;; Command to run + (iup:frame + #:title "Set the action to take" + (iup:hbox + ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") + (let* ((cmds-list '("runtests" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + ;; (print obj " " val " " index " " lbstate) + (dboard:data-set-command! *data* val) + (dashboard:update-run-command)))) + (default-cmd (car cmds-list))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (dboard:data-set-command! *data* default-cmd) + lb))) + + (iup:frame + #:title "Runname" + (let* ((default-run-name (seconds->work-week/day (current-seconds))) + (tb (iup:textbox #:expand "HORIZONTAL" + #:action (lambda (obj val txt) + ;; (print "obj: " obj " val: " val " unk: " unk) + (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) + (dashboard:update-run-command)) + #:value default-run-name)) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (iup:attribute-set! tb "VALUE" val) + (dboard:data-set-run-name! *data* val) + (dashboard:update-run-command)))) + (refresh-runs-list (lambda () + (let* ((target (dboard:data-get-target-string *data*)) + (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) + (runs-header (vector-ref runs-for-targ 0)) + (runs-dat (vector-ref runs-for-targ 1)) + (run-names (cons default-run-name + (map (lambda (x) + (db:get-value-by-header x runs-header "runname")) + runs-dat)))) + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) + (set! updater-for-runs refresh-runs-list) + (refresh-runs-list) + (dboard:data-set-run-name! *data* default-run-name) + (iup:hbox + tb + lb))) + + (iup:frame + #:title "SELECTORS" + (iup:vbox + ;; Text box for test patterns + (iup:frame + #:title "Test patterns (one per line)" + (let ((tb (iup:textbox #:action (lambda (val a b) + (dboard:data-set-test-patts! + *data* + (dboard:lines->test-patt b)) + (dashboard:update-run-command)) + #:value (dboard:test-patt->lines + (dboard:data-get-test-patts *data*)) + #:expand "YES" + #:size "x50" + #:multiline "YES"))) + (set! test-patterns-textbox tb) + tb)) + (iup:frame + #:title "Target" + ;; Target selectors + (apply iup:hbox + (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) + (key-lb (car dat)) + (combos (cadr dat))) + (set! key-listboxes key-lb) + combos))) + (iup:hbox + ;; Text box for STATES + (iup:frame + #:title "States" + (dashboard:text-list-toggle-box + ;; Move these definitions to common and find the other useages and replace! + (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + (lambda (all) + (dboard:data-set-states! *data* all) + (dashboard:update-run-command)))) + ;; Text box for STATES + (iup:frame + #:title "Statuses" + (dashboard:text-list-toggle-box + (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + (lambda (all) + (dboard:data-set-statuses! *data* all) + (dashboard:update-run-command)))))))) + + (iup:frame + #:title "Tests and Tasks" + (let* ((updater #f) + (last-xadj 0) + (last-yadj 0) + (the-cnv #f) + (canvas-obj + (iup:canvas #:action (make-canvas-action + (lambda (cnv xadj yadj) + (if (not updater) + (set! updater (lambda (xadj yadj) + ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (set! last-xadj xadj) + (set! last-yadj yadj)))) + (updater xadj yadj) + (set! the-cnv cnv) + )) + ;; Following doesn't work + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (let ((xadj last-xadj) + (yadj (+ last-yadj (if (> step 0) + -0.01 + 0.01)))) + ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") + ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) + (if the-cnv + (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames)) + (set! last-xadj xadj) + (set! last-yadj yadj) + )) + ;; #:size "50x50" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:button-cb (lambda (obj btn pressed x y status) + ;; (print "obj: " obj) + (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) + ;; (print "x\ty\tllx\tlly\turx\tury") + (for-each (lambda (test-name) + (let* ((rec-coords (hash-table-ref tests-info test-name)) + (llx (list-ref rec-coords 0)) + (urx (list-ref rec-coords 1)) + (lly (list-ref rec-coords 2)) + (ury (list-ref rec-coords 3))) + ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " + (if (and (eq? pressed 1) + (> x llx) + (> y lly) + (< x urx) + (< y ury)) + (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((selected (not (member test-name patterns))) + (newpatt-list (if selected + (cons test-name patterns) + (delete test-name patterns))) + (newpatt (string-intersperse newpatt-list "\n"))) + ;; (if cnv-obj + ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) + (iup:attribute-set! obj "REDRAW" "ALL") + (hash-table-set! selected-tests test-name selected) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) + (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command) + (if updater (updater last-xadj last-yadj))))))) + (hash-table-keys tests-info))))))) + canvas-obj))) + ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) + + (iup:frame + #:title "Logs" ;; To be replaced with tabs + (let ((logs-tb (iup:textbox #:expand "YES" + #:multiline "YES"))) + (dboard:data-set-logs-textbox! *data* logs-tb) + logs-tb)))))) + + +;; (trace dashboard:populate-target-dropdown +;; common:list-is-sublist) +;; +;; ;; key1 key2 key3 ... +;; ;; target entry (wild cards allowed) +;; +;; ;; The action +;; (iup:hbox +;; ;; label Action | action selector +;; )) +;; ;; Test/items selector +;; (iup:hbox +;; ;; tests +;; ;; items +;; )) +;; ;; The command line +;; (iup:hbox +;; ;; commandline entry +;; ;; GO button +;; ) +;; ;; The command log monitor +;; (iup:tabs +;; ;; log monitor +;; ))) + +;;====================================================================== +;; S U M M A R Y +;;====================================================================== +;; +;; General info about the run(s) and megatest area +(define (dashboard:summary db) + (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) + (iup:vbox + (iup:split + #:value 500 + (iup:frame + #:title "General Info" + (iup:vbox + (iup:hbox + (iup:label "Area Path") + (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + ))) + (iup:frame + #:title "Server" + (dcommon:servers-table))) + (iup:frame + #:title "Megatest config settings" + (iup:hbox + (dcommon:section-matrix rawconfig "setup" "Varname" "Value") + (iup:vbox + (dcommon:section-matrix rawconfig "server" "Varname" "Value") + ;; (iup:frame + ;; #:title "Disks Areas" + (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) + (iup:frame + #:title "Run statistics" + (dcommon:run-stats db))))) + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +(define (tree-path->run-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) + #f)) + +(define dashboard:update-run-summary-tab #f) + +;; (define (tests window-id) +(define (dashboard:one-run db) + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-set-curr-run-id! *data* run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) + (cell-lookup (make-hash-table)) + (run-matrix (iup:matrix + #:expand "YES" + #:click-cb + (lambda (obj lin col status) + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) + (system cmd))))) + (updater (lambda () + (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (run-id (dboard:data-get-curr-run-id *data*)) + (tests-dat (let ((tdat (db:get-tests-for-run db run-id + (hash-table-ref/default *searchpatts* "test-name" "%/%") + (hash-table-keys *state-ignore-hash*) ;; '() + (hash-table-keys *status-ignore-hash*) ;; '() + #f #f + *hide-not-hide* + #f #f + "id,testname,item_path,state,status"))) ;; get 'em all + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) + (tests-mindat (dcommon:minimize-test-data tests-dat)) + (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b)))))) + + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; Update the runs tree + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + *keys*)) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name))) + (existing (tree:find-node tb run-path))) + (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f)) + (begin + (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) + run-ids) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) + ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) + + (set! dashboard:update-run-summary-tab updater) + (dboard:data-set-runs-tree! *data* tb) + (iup:split + tb + run-matrix))) + +;;====================================================================== +;; R U N S +;;====================================================================== -(define (make-dashboard-buttons nruns ntests keynames) +(define (make-dashboard-buttons db nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) @@ -455,103 +1209,136 @@ ;; (mark-for-update) ;; (update-search "item-name" val)) )) (iup:vbox (iup:hbox - (iup:button "Sort" #:action (lambda (obj) - (set! *tests-sort-reverse* (not *tests-sort-reverse*)) - (iup:attribute-set! obj "TITLE" (if *tests-sort-reverse* "+Sort" "-Sort")) - (mark-for-update))) + (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (mark-for-update) + ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) + lb) + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update))) (iup:button "HideEmpty" #:action (lambda (obj) (set! *hide-empty-runs* (not *hide-empty-runs*)) - (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+Hide" "-Hide")) + (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) (mark-for-update))) - (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update)))) + (let ((hideit (iup:button "HideTests" #:action (lambda (obj) + (set! *hide-not-hide* (not *hide-not-hide*)) + (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) + (mark-for-update))))) + (set! *hide-not-hide-button* hideit) + hideit)) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit))) - (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &"))))) - )) - ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1)))) - ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0)))) - ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1))))) - ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset* (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0)))) + (iup:button "Quit" #:action (lambda (obj) + ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) + (exit))) + (iup:button "Refresh" #:action (lambda (obj) + (mark-for-update))) + (iup:button "Collapse" #:action (lambda (obj) + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + *all-item-test-names*) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update)))))) (iup:frame - #:title "hide" + #:title "state/status filter" (iup:vbox (apply iup:hbox (map (lambda (status) (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *status-ignore-hash* status #t) - (hash-table-delete! *status-ignore-hash* status))))) - '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (hash-table-delete! *status-ignore-hash* status)) + (set-bg-on-filter)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *state-ignore-hash* state #t) - (hash-table-delete! *state-ignore-hash* state))))) - '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (hash-table-delete! *state-ignore-hash* state)) + (set-bg-on-filter)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns *tot-run-count*)) (set! *start-run-offset* val) (mark-for-update) (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "YES" - #:max (* 10 (length *allruns*))))) - ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) + #:expand "HORIZONTAL" + #:max (* 10 (length *allruns*)) + #:min 0 + #:step 0.01))) + ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) ) ) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" - (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") - (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search x val)))))) + (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") + (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" + #:action (lambda (obj unk val) + (mark-for-update) + (update-search x val)))))) (set! i (+ i 1)) res)) keynames))))) (let loop ((testnum 0) (res '())) (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length *alltestnamelst*)))) - (set! *please-update-buttons* #t) - (set! *start-test-offset* (inexact->exact (round (/ val 10)))) - (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL") - (apply iup:vbox (reverse res))))))) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (string->number (iup:attribute obj "VALUE"))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (newmax (* 10 (length *alltestnamelst*)))) + (set! *please-update-buttons* #t) + (set! *start-test-offset* (inexact->exact (round (/ val 10)))) + (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) + (if (< val 10) + (iup:attribute-set! obj "MAX" newmax)) + )) + #:expand "VERTICAL" + #:orientation "VERTICAL" + #:min 0 + #:step 0.01) + (apply iup:vbox (reverse res))))))) (else (let ((labl (iup:button "" #:flat "YES" #:alignment "ALEFT" - ; #:image img1 - ; #:impress img2 + ; #:image img1 + ; #:impress img2 #:size "x15" #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (obj) (mark-for-update) @@ -592,94 +1379,204 @@ #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " test-id "&"))) - ;(print "Launching " cmd) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (cmd (conc toolpath " -test " run-id "," test-id "&"))) + ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog - #:title "Megatest dashboard" - (iup:vbox - (apply iup:hbox - (cons (apply iup:vbox lftlst) - (list - (iup:vbox - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst)))))) - controls))) + #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) + #:menu (dcommon:main-menu) + (let* ((runs-view (iup:vbox + (apply iup:hbox + (cons (apply iup:vbox lftlst) + (list + (iup:vbox + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst)))))) + controls)) + (tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *please-update-buttons* #t) + (set! *current-tab-number* curr)) + (dashboard:summary db) + runs-view + (dashboard:one-run db) + (dashboard:run-controls) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Summary") + (iup:attribute-set! tabs "TABTITLE1" "Runs") + (iup:attribute-set! tabs "TABTITLE2" "Run Summary") + (iup:attribute-set! tabs "TABTITLE3" "Run Control") + (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + (set! *hide-not-hide-tabs* tabs) + tabs))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin - (set! *num-tests* (string->number (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" *num-runs* "%/%" '())) + (set! *num-tests* (string->number (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS")))) + (update-rundat "%" *num-runs* "%/%" '())) (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") -;; Move this stuff to db.scm FIXME +;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; -(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))) -(define (db:been-changed) - (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*)) -(define (db:set-db-update-time) - (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))) - -(define (run-update x) - (update-buttons uidat *num-runs* *num-tests*) - ;; (if (db:been-changed) - (begin - (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* - (hash-table-ref/default *searchpatts* "test-name" "%/%") - ;; (hash-table-ref/default *searchpatts* "item-name" "%") - (let ((res '())) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default *searchpatts* key #f))) - (if val (set! res (cons (list key val) res)))))) - *dbkeys*) - res)) - ; (db:set-db-update-time) - )) +(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) +(define *last-recalc-ended-time* 0) + +(define (dashboard:been-changed) + (> (file-modification-time *db-file-path*) *last-db-update-time*)) + +(define (dashboard:set-db-update-time) + (set! *last-db-update-time* (file-modification-time *db-file-path*))) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) + (> modtime last-db-update-time) + (> (current-seconds)(+ last-db-update-time 1))))) + +(define *monitor-db-path* (conc *dbdir* "/monitor.db")) +(define *last-monitor-update-time* 0) + +;; Force creation of the db in case it isn't already there. +(tasks:open-db) + +(define (dashboard:get-youngest-run-db-mod-time) + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (apply max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc *dbdir* "/*.db")))))) + +(define (dashboard:run-update x) + (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) + (monitor-modtime (if (file-exists? *monitor-db-path*) + (file-modification-time *monitor-db-path*) + -1)) + (run-update-time (current-seconds)) + (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) + (if (and (eq? *current-tab-number* 0) + (> monitor-modtime *last-monitor-update-time*)) + (begin + (set! *last-monitor-update-time* monitor-modtime) + (if dashboard:update-servers-table (dashboard:update-servers-table)))) + (if recalc + (begin + (case *current-tab-number* + ((0) + (if dashboard:update-summary-tab (dashboard:update-summary-tab))) + ((1) ;; The runs table is active + (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* + (hash-table-ref/default *searchpatts* "test-name" "%/%") + ;; (hash-table-ref/default *searchpatts* "item-name" "%") + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default *searchpatts* key #f))) + (if val (set! res (cons (list key val) res)))))) + *dbkeys*) + res)) + (update-buttons uidat *num-runs* *num-tests*)) + ((2) + (dashboard:update-run-summary-tab)) + (else + (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) + (if updater (updater))))) + (set! *please-update-buttons* #f) + (set! *last-db-update-time* modtime) + (set! *last-update* run-update-time) + (set! *last-recalc-ended-time* (current-milliseconds)))))) + +;;====================================================================== +;; The heavy lifting starts here +;;====================================================================== + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) - (on-exit (lambda () - (if *db* (sqlite3:finalize! *db*)))) - (cdb:remote-run examine-run *db* runid))) + (on-exit std-exit-procedure) + (examine-run *dbstruct-local* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) - ((args:get-arg "-test") - (let ((testid (string->number (args:get-arg "-test")))) - (if testid - (examine-test testid) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (examine-test run-id test-id) (begin - (print "ERROR: testid is not a number " (args:get-arg "-test")) + (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") - (gui-monitor *db*)) + (gui-monitor *dbstruct-local*)) (else - (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) + (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) - (run-update x))))) - ;(print x))))) + (let ((update-is-running #f)) + (mutex-lock! *update-mutex*) + (set! update-is-running *update-is-running*) + (if (not update-is-running) + (set! *update-is-running* #t)) + (mutex-unlock! *update-mutex*) + (if (not update-is-running) + (begin + (dashboard:run-update x) + (mutex-lock! *update-mutex*) + (set! *update-is-running* #f) + (mutex-unlock! *update-mutex*)))) + 1)))) + +(let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (set! *please-update-buttons* #t) + (dashboard:run-update 1)) "update buttons once")) + ;; need to wait for first *update-is-running* #t + ;; (let loop () + ;; (mutex-lock! *update-mutex*) + ;; (if *update-is-running* + ;; (begin + ;; (set! *please-update-buttons* #t) + ;; (mark-for-update) + ;; (print "Did redraw trigger")) "First update after startup") + ;; (mutex-unlock! *update-mutex*) + ;; (thread-sleep! 1) + ;; (if (not *please-update-buttons*) + ;; (loop)))))) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2)) -(iup:main-loop) +;; (iup:main-loop)(db:close-all *dbstruct-local*) ADDED datashare-testing/.sd.config Index: datashare-testing/.sd.config ================================================================== --- /dev/null +++ datashare-testing/.sd.config @@ -0,0 +1,35 @@ +# Read in the users vars first (so the offical data cannot be overridden +[include ~/.datashare.config] + +# Read in local overrides +[include datashare.config] + +# Replace [storage] with settings entry - more secure +[settings] + +storage /tmp/#{getenv USER}/datashare/disk1 \ + /tmp/#{getenv USER}/datashare/disk2 + +basepath #{getenv BASEPATH} + +[areas] +synthesis asic/synthesis +verilog asic/verilog +customlibs custom/oalibs +megatest tools/megatest + +[quality] +0 untested +1 lightly tested +2 tested +3 full QA + +[database] +location /tmp/#{getenv USER}/datashare + +[pathmaps] +SHELF /tmp/#{getenv USER}/theshelf + +[buildmethods] +customlibs make setup;make install + ADDED datashare.scm Index: datashare.scm ================================================================== --- /dev/null +++ datashare.scm @@ -0,0 +1,817 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use ssax) +(use sxml-serializer) +(use sxml-modifications) +(use regex) +(use srfi-69) +(use regex-case) +(use posix) +(use json) +(use csv) +(use srfi-18) +(use format) + +(require-library iup) +(import (prefix iup iup:)) +(require-library ini-file) +(import (prefix ini-file ini:)) + +(use canvas-draw) +(import canvas-draw-iup) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (uses configf)) +(declare (uses tree)) +(declare (uses margs)) +;; (declare (uses dcommon)) +;; (declare (uses launch)) +;; (declare (uses gutils)) +;; (declare (uses db)) +;; (declare (uses synchash)) +;; (declare (uses server)) +;; (declare (uses megatest-version)) +;; (declare (uses tbd)) + +(include "megatest-fossil-hash.scm") + +;; +;; GLOBALS +;; +(define *datashare:current-tab-number* 0) +(define *args-hash* (make-hash-table)) +(define datashare:help (conc "Usage: datashare [action [params ...]] + +Note: run datashare without parameters to start the gui. + + list-areas : List the allowed areas + + list-versions : List versions available in + options : -full, -vpatt patt + + publish : Publish data for area and with version + + get : Get a link to data, put the link in destpath + options : -i iteration + + update : Update the link to data to the latest iteration. + +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) ;; " + +;;====================================================================== +;; RECORDS +;;====================================================================== + +;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment +;; testing +(define (make-datashare:pkg)(make-vector 15)) +(define-inline (datashare:pkg-get-id vec) (vector-ref vec 0)) +(define-inline (datashare:pkg-get-area vec) (vector-ref vec 1)) +(define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2)) +(define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3)) +(define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4)) +(define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5)) +(define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6)) +(define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7)) +(define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8)) +(define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9)) +(define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10)) +(define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11)) +(define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12)) +(define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13)) +(define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14)) +(define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val)) +(define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val)) +(define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val)) +(define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val)) +(define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val)) +(define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val)) +(define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val)) +(define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val)) +(define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val)) +(define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val)) +(define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val)) +(define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val)) +(define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val)) +(define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val)) + +;;====================================================================== +;; DB +;;====================================================================== + +(define (datashare:initialize-db db) + (for-each + (lambda (qry) + (sqlite3:execute db qry)) + (list + "CREATE TABLE pkgs + (id INTEGER PRIMARY KEY, + area TEXT, + version_name TEXT, + store_type TEXT DEFAULT 'copy', + copied INTEGER DEFAULT 0, + source_path TEXT, + stored_path TEXT, + iteration INTEGER DEFAULT 0, + submitter TEXT, + datetime TIMESTAMP DEFAULT (strftime('%s','now')), + storegrp TEXT, + datavol INTEGER, + quality TEXT, + disk_id INTEGER, + comment TEXT);" + "CREATE TABLE refs + (id INTEGER PRIMARY KEY, + pkg_id INTEGER, + destlink TEXT);" + "CREATE TABLE disks + (id INTEGER PRIMARY KEY, + storegrp TEXT, + path TEXT);"))) + +(define (datashare:register-data db area version-name store-type submitter quality source-path comment) + (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) + (next-iteration 0)) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row + (lambda (iteration) + (if (and (number? iteration) + (>= iteration next-iteration)) + (set! next-iteration (+ iteration 1)))) + iter-qry area version-name) + ;; now store the data + (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) + VALUES (?,?,?,?,?,?,?,?);" + area version-name next-iteration (conc store-type) submitter source-path quality comment))) + (sqlite3:finalize! iter-qry) + next-iteration)) + +(define (datashare:get-id db area version-name iteration) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" + area version-name iteration) + res)) + +(define (datashare:set-stored-path db id path) + (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) + +(define (datashare:set-copied db id value) + (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) + +(define (datashare:get-pkg-record db area version-name iteration) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + db + "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" + area + version-name + iteration) + res)) + +;; take version-name iteration and register or update "lastest/0" +;; +(define (datashare:set-latest db id area version-name iteration) + (let* ((rec (datashare:get-pkg-record db area version-name iteration)) + (latest-id (datashare:get-id db area "latest" 0)) + (stored-path (datashare:pkg-get-stored_path rec))) + (if latest-id ;; have a record - bump the link pointer + (datashare:set-stored-path db latest-id stored-path) + (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data")))) + +;; set a package ref, this is the location where the link back to the stored data +;; is put. +;; +;; if there is nothing at that location then the record can be removed +;; if there are no refs for a particular pkg-id then that pkg-id is a +;; candidate for removal +;; +(define (datashare:record-pkg-ref db pkg-id dest-link) + (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) + +(define (datashare:count-refs db pkg-id) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + db + "SELECT count(id) FROM refs WHERE pkg_id=?;" + pkg-id) + res)) + +;; Create the sqlite db +(define (datashare:open-db configdat) + (let ((path (configf:lookup configdat "database" "location"))) + (if (and path + (directory? path) + (file-read-access? path)) + (let* ((dbpath (conc path "/datashare.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath)) + (handler (make-busy-timeout 136000))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit)) + (set! db (sqlite3:open-database dbpath))) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (if (not dbexists) + (begin + (datashare:initialize-db db))) + db) + (print "ERROR: invalid path for storing database: " path)))) + +(define (open-run-close-exception-handling proc idb . params) + (handle-exceptions + exn + (let ((sleep-time (random 30)) + (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (case err-status + ((busy) + (thread-sleep! sleep-time)) + (else + (print "EXCEPTION: database overloaded or unreadable.") + (print " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain (current-error-port)) + (thread-sleep! sleep-time) + (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) + (apply open-run-close-exception-handling proc idb params)) + (apply open-run-close-no-exception-handling proc idb params))) + +(define (open-run-close-no-exception-handling proc idb . params) + ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (print "ERROR: cannot open-run-close with #f anymore")))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! dbstruct)) + ;; (print "open-run-close-no-exception-handling END" ) + res)) + +(define open-run-close open-run-close-no-exception-handling) + +(define (datashare:get-pkgs db area-filter version-filter iter-filter) + (let ((res '())) + (sqlite3:for-each-row ;; replace with fold ... + (lambda (a . b) + (set! res (cons (list->vector (cons a b)) res))) + db + (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " + " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";") + area-filter version-filter) + (reverse res))) + +(define (datashare:get-pkg db area-name version-name #!key (iteration #f)) + (let ((dat '()) + (res #f)) + (sqlite3:for-each-row ;; replace with fold ... + (lambda (a . b) + (set! dat (cons (list->vector (cons a b)) dat))) + db + (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " + " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;") + area-name version-name) + ;; now filter for iteration, either max if #f or specific one + (if (null? dat) + #f + (let loop ((hed (car dat)) + (tal (cdr dat)) + (cur 0)) + (let ((itr (datashare:pkg-get-iteration hed))) + (if (equal? itr iteration) ;; this is the one if iteration is specified + hed + (if (null? tal) + hed + (loop (car tal)(cdr tal))))))))) + +(define (datashare:get-versions-for-area db area-name #!key (version-patt #f)) + (let ((res '()) + (data (make-hash-table))) + (sqlite3:for-each-row + (lambda (version-name submitter iteration submitted-time comment) + ;; 0 1 2 3 4 + (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))) + db + "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;" + (or version-patt "%")) + (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=)))) + +;;====================================================================== +;; DATA IMPORT/EXPORT +;;====================================================================== + +(define (datashare:import-data configdat source-path dest-path area version iteration) + (let* ((space-avail (car dest-path)) + (disk-path (cdr dest-path)) + (targ-path (conc disk-path "/" area "/" version "/" iteration)) + (id (datashare:get-id db area version iteration)) + (db (datashare:open-db configdat))) + (if (> space-avail 10000) ;; dumb heuristic + (begin + (create-directory targ-path #t) + (datashare:set-stored-path db id targ-path) + (print "Running command: rsync -av " source-path "/ " targ-path "/") + (let ((th1 (make-thread (lambda () + (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) + (process-wait pid) + (datashare:set-copied db id "yes") + (sqlite3:finalize! db))) + "Data copy"))) + (thread-start! th1)) + #t) + (begin + (print "ERROR: Not enough space in storage area " dest-path) + (datashare:set-copied db id "no") + (sqlite3:finalize! db) + #f)))) + +(define (datashare:get-areas configdat) + (let* ((areadat (configf:get-section configdat "areas")) + (areas (if areadat (map car areadat) '()))) + areas)) + +(define (datashare:publish configdat publish-type area-name version comment spath submitter quality) + ;; input checks + (cond + ((not (member area-name (datashare:get-areas configdat))) + (cons #f (conc "Illegal area name \"" area-name "\""))) + (else + (let ((db (datashare:open-db configdat)) + (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment)) + (dest-store (datashare:get-best-storage configdat))) + (if iteration + (if (eq? 'copy publish-type) + (begin + (datashare:import-data configdat spath dest-store area-name version iteration) + (let ((id (datashare:get-id db area-name version iteration))) + (datashare:set-latest db id area-name version iteration))) + (let ((id (datashare:get-id db area-name version iteration))) + (datashare:set-stored-path db id spath) + (datashare:set-copied db id "yes") + (datashare:set-copied db id "n/a") + (datashare:set-latest db id area-name version iteration))) + (print "ERROR: Failed to get an iteration number")) + (sqlite3:finalize! db) + (cons #t "Successfully saved data"))))) + +(define (datashare:get-best-storage configdat) + (let* ((storage (configf:lookup configdat "settings" "storage")) + (store-areas (if storage (string-split storage) '()))) + (print "Looking for available space in " store-areas) + (datashare:find-most-space store-areas))) + +;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3)) + +(define (datashare:find-most-space paths) + (fold (lambda (area res) + ;; (print "area=" area " res=" res) + (let ((maxspace (car res)) + (currpath (cdr res))) + ;; (print currpath " " maxspace) + (if (file-write-access? area) + (let ((currspace (string->number + (list-ref + (with-input-from-pipe + ;; (conc "df --output=avail " area) + (conc "df -B1000000 " area) + ;; (lambda ()(read)(read)) + (lambda ()(read-line)(string-split (read-line)))) + 3)))) + (if (> currspace maxspace) + (cons currspace area) + res)) + res))) + (cons 0 #f) + paths)) + +;; remove existing link and if possible ... +;; create path to next of tip of target, create link back to source +(define (datashare:build-dir-make-link source target) + (if (file-exists? target)(datashare:backup-move target)) + (create-directory (pathname-directory target) #t) + (create-symbolic-link source target)) + +(define (datashare:backup-move path) + (let* ((trashdir (conc (pathname-directory path) "/.trash")) + (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) + (create-directory trashdir #t) + (if (directory? path) + (system (conc "mv " path " " trashfile)) + (file-move path trash-file)))) + +;;====================================================================== +;; GUI +;;====================================================================== + +;; The main menu +(define (datashare:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +(define (datashare:publish-view configdat) + ;; (pp (hash-table->alist configdat)) + (let* ((areas (configf:get-section configdat "areas")) + (label-size "70x") + (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) + (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) + (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) + (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) + (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) + ;; (copy-link (iup:toggle #:expand "HORIZONTAL")) + ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) + ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) + (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%")) + (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) + (source-tb (iup:textbox #:expand "HORIZONTAL" + #:value (or (configf:lookup configdat "settings" "basepath") + ""))) + (publish (lambda (publish-type) + (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) + (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) + (area-path (cadr area-dat)) + (area-name (car area-dat)) + (version (iup:attribute version-tb "VALUE")) + (comment (iup:attribute comment-tb "VALUE")) + (spath (iup:attribute source-tb "VALUE")) + (submitter (current-user-name)) + (quality 2)) + (datashare:publish configdat publish-type area-name version comment spath submitter quality)))) + (copy (iup:button "Copy and Publish" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (publish 'copy)))) + (link (iup:button "Link and Publish" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (publish 'link)))) + (browse-btn (iup:button "Browse" + #:size "40x" + #:action (lambda (obj) + (let* ((fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! source-tb "VALUE" + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))))) + (print "areas") + ;; (pp areas) + (fold (lambda (areadat num) + ;; (print "Adding num=" num ", areadat=" areadat) + (iup:attribute-set! areas-sel (conc num) (car areadat)) + (+ 1 num)) + 1 areas) + (iup:vbox + (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter + areas-sel) + (iup:hbox (iup:label "Version:" #:size label-size) version-tb) + ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link) + ;; (iup:label "Iteration:") iteration) + (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb) + (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn) + (iup:hbox copy link)))) + +(define (datashare:lst->path pathlst) + (conc "/" (string-intersperse (map conc pathlst) "/"))) + +(define (datashare:path->lst path) + (string-split path "/")) + +(define (datashare:pathdat-apply-heuristics configdat path) + (cond + ((file-exists? path) "found") + (else (conc path " not installed")))) + +(define (datashare:get-view configdat) + (iup:vbox + (iup:hbox + (let* ((label-size "60x") + ;; filter elements + (area-filter "%") + (version-filter "%") + (iter-filter ">= 0") + ;; reverse lookup from path to data for src and installed + (srcdat (make-hash-table)) ;; reverse lookup + (installed-dat (make-hash-table)) + ;; config values + (basepath (configf:lookup configdat "settings" "basepath")) + ;; gui elements + (submitter (iup:label "" #:expand "HORIZONTAL")) + (date-submitted (iup:label "" #:expand "HORIZONTAL")) + (comment (iup:label "" #:expand "HORIZONTAL")) + (copy-link (iup:label "" #:expand "HORIZONTAL")) + (quality (iup:label "" #:expand "HORIZONTAL")) + (installed-status (iup:label "" #:expand "HORIZONTAL")) + ;; misc + (curr-record #f) + ;; (source-data (iup:label "" #:expand "HORIZONTAL")) + (tb (iup:treebox + #:value 0 + #:name "Packages" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) + (record (hash-table-ref/default srcdat path #f))) + (if record + (begin + (set! curr-record record) + (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record)) + (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record)))) + (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record)) + (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record)) + (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record)) + )) + ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) + )))) + (tb2 (iup:treebox + #:value 0 + #:name "Installed" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) + (status (hash-table-ref/default installed-dat path #f))) + (iup:attribute-set! installed-status "TITLE" (if status status "")) + )))) + (refresh (lambda (obj) + (let* ((db (datashare:open-db configdat)) + (areas (or (configf:get-section configdat "areas") '()))) + ;; + ;; first update the Sources + ;; + (for-each + (lambda (pkgitem) + (let* ((pkg-path (list (datashare:pkg-get-area pkgitem) + (datashare:pkg-get-version_name pkgitem) + (datashare:pkg-get-iteration pkgitem))) + (pkg-id (datashare:pkg-get-id pkgitem)) + (path (datashare:lst->path pkg-path))) + ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id) + (if (not (hash-table-ref/default srcdat path #f)) + (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id))) + ;; (print "path=" path " pkgitem=" pkgitem) + (hash-table-set! srcdat path pkgitem))) + (datashare:get-pkgs db area-filter version-filter iter-filter)) + ;; + ;; then update the installed + ;; + (for-each + (lambda (area) + (let* ((path (conc "/" (cadr area))) + (fullpath (conc basepath path))) + (if (not (hash-table-ref/default installed-dat path #f)) + (tree:add-node tb2 "Installed" (datashare:path->lst path))) + (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath)))) + areas) + (sqlite3:finalize! db)))) + (apply (iup:button "Apply" + #:action + (lambda (obj) + (if curr-record + (let* ((area (datashare:pkg-get-area curr-record)) + (stored-path (datashare:pkg-get-stored_path curr-record)) + (source-type (datashare:pkg-get-store_type curr-record)) + (source-path (case source-type ;; (equal? source-type "link")) + ((link)(datashare:pkg-get-source-path curr-record)) + ((copy)stored-path) + (else #f))) + (dest-stub (configf:lookup configdat "areas" area)) + (target-path (conc basepath "/" dest-stub))) + (datashare:build-dir-make-link stored-path target-path) + (print "Creating link from " stored-path " to " target-path))))))) + (iup:vbox + (iup:hbox tb tb2) + (iup:frame + #:title "Source Info" + (iup:vbox + (iup:hbox (iup:button "Refresh" #:action refresh) apply) + (iup:hbox (iup:label "Submitter: ") ;; #:size label-size) + submitter + (iup:label "Submitted on: ") ;; #:size label-size) + date-submitted) + (iup:hbox (iup:label "Data stored: ") + copy-link + (iup:label "Quality: ") + quality) + (iup:hbox (iup:label "Comment: ") + comment))) + (iup:frame + #:title "Installed Info" + (iup:vbox + (iup:hbox (iup:label "Installed status/path: ") installed-status))) + ))))) + +(define (datashare:manage-view configdat) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (datashare:gui configdat) + (iup:show + (iup:dialog + #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory)) + #:menu (datashare:main-menu) + (let* ((tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *datashare:current-tab-number* curr)) + (datashare:publish-view configdat) + (datashare:get-view configdat) + (datashare:manage-view configdat) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Publish") + (iup:attribute-set! tabs "TABTITLE1" "Get") + (iup:attribute-set! tabs "TABTITLE2" "Manage") + ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + tabs))) + (iup:main-loop)) + +;;====================================================================== +;; MISC +;;====================================================================== + + +(define (datashare:do-as-calling-user proc) + (let ((eid (current-effective-user-id)) + (cid (current-user-id))) + (if (not (eq? eid cid)) ;; running suid + (set! (current-effective-user-id) cid)) + ;; (print "running as " (current-effective-user-id)) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + +(define (datashare:find name paths) + (if (null? paths) + #f + (let loop ((hed (car paths)) + (tal (cdr paths))) + (if (file-exists? (conc hed "/" name)) + hed + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + +;;====================================================================== +;; MAIN +;;====================================================================== + +(define (datashare:load-config exe-dir exe-name) + (let* ((fname (conc exe-dir "/." exe-name ".config"))) + (ini:property-separator-patt " * *") + (ini:property-separator #\space) + (if (file-exists? fname) + ;; (ini:read-ini fname) + (read-config fname #f #t) + (make-hash-table)))) + +(define (datashare:process-action configdat action . args) + (case (string->symbol action) + ((get) + (if (< (length args) 2) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1)) + (let* ((basepath (configf:lookup configdat "settings" "basepath")) + (db (datashare:open-db configdat)) + (area (car args)) + (version (cadr args)) ;; iteration + (remargs (args:get-args args '("-i") '() args:arg-hash 0)) + (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f)) + (curr-record (datashare:get-pkg db area version iteration: iteration))) + (if (not curr-record) + (begin + (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)")) + (exit 1)) + (let* ((stored-path (datashare:pkg-get-stored_path curr-record)) + (source-type (datashare:pkg-get-store_type curr-record)) + (source-path (case source-type ;; (equal? source-type "link")) + ((link) (datashare:pkg-get-source-path curr-record)) + ((copy) stored-path) + (else #f))) + (dest-stub (configf:lookup configdat "areas" area)) + (target-path (conc basepath "/" dest-stub))) + (datashare:build-dir-make-link stored-path target-path) + (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path) + (sqlite3:finalize! db) + (print "Creating link from " stored-path " to " target-path)))))) + ((publish) + (if (< (length args) 3) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1)) + (let* ((srcpath (list-ref args 0)) + (areaname (list-ref args 1)) + (version (list-ref args 2)) + (remargs (args:get-args (drop args 2) + '("-type" ;; link or copy (default is copy) + "-m") + '() + args:arg-hash + 0)) + (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy)) + (comment (or (args:get-arg "-m") "")) + (submitter (current-user-name)) + (quality (args:get-arg "-quality")) + (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality))) + (if (not (car publish-res)) + (begin + (print "ERROR: " (cdr publish-res)) + (exit 1)))))) + ((list-versions) + (let ((area-name (car args)) ;; version patt full print + (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0)) + (db (datashare:open-db configdat)) + (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt")))) + ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) + (map (lambda (x) + (if (args:get-arg "-full") + (format #t + "~10a~10a~4a~27a~30a\n" + (vector-ref x 0) + (vector-ref x 1) + (vector-ref x 2) + (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") + (conc "\"" (vector-ref x 4) "\"")) + (print (vector-ref x 0)))) + versions) + (sqlite3:finalize! db))))) + +;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (exe-name (pathname-file (car (argv)))) + (exe-dir (or (pathname-directory prog) + (datashare:find exe-name (string-split (get-environment-variable "PATH") ":")))) + (configdat (datashare:load-config exe-dir exe-name))) + (cond + ;; one-word commands + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((help -h -help --h --help) + (print datashare:help)) + ((list-areas) + (map print (datashare:get-areas configdat))) + (else + (print "ERROR: Unrecognised command. Try \"datashare help\"")))) + ;; multi-word commands + ((null? rema)(datashare:gui configdat)) + ((>= (length rema) 2) + (apply datashare:process-action configdat (car rema)(cdr rema))) + (else (print "ERROR: Unrecognised command. Try \"datashare help\""))))) + +(main) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -11,207 +11,757 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) ;; rpc) -;; (import (prefix rpc rpc:)) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(require-extension (srfi 18) extras tcp) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) -;; Note, try to remove this dependency -;; (use zmq) - (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) -(declare (uses fs-transport)) (declare (uses client)) +(declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") -;; timestamp type (val1 val2 ...) -;; type: meta-info, step -(define *incoming-writes* '()) -(define *completed-writes* (make-hash-table)) -(define *incoming-last-time* (current-seconds)) -(define *incoming-mutex* (make-mutex)) -(define *completed-mutex* (make-mutex)) -(define *cache-on* #f) - +(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +;;====================================================================== +;; SQLITE3 HELPERS +;;====================================================================== + +;; convert to -inline +(define (db:first-result-default db stmt default . params) + (handle-exceptions + exn + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) + (if (eq? err-status 'done) + default + (begin + (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + default))) + (apply sqlite3:first-result db stmt params))) + +;; Get/open a database +;; if run-id => get run specific db +;; if #f => get main db +;; if db already open - return inmem +;; if db not open, open inmem, rundb and sync then return inmem +;; inuse gets set automatically for rundb's +;; +(define (db:get-db dbstruct run-id) + (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through + dbstruct + (begin + (mutex-lock! *rundb-mutex*) + (let ((dbdat (if (or (not run-id) + (eq? run-id 0)) + (db:open-main dbstruct) + (db:open-rundb dbstruct run-id) + ))) + ;; db prunning would go here + (mutex-unlock! *rundb-mutex*) + dbdat)))) + +(define (db:dbdat-get-db dbdat) + (if (pair? dbdat) + (car dbdat) + dbdat)) + +(define (db:dbdat-get-path dbdat) + (if (pair? dbdat) + (cdr dbdat) + #f)) + +;; mod-read: +;; 'mod modified data +;; 'read read data +;; +(define (db:done-with dbstruct run-id mod-read) + (if (not (sqlite3:database? dbstruct)) + (begin + (mutex-lock! *rundb-mutex*) + (if (eq? mod-read 'mod) + (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds)) + (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) + (dbr:dbstruct-set-inuse! dbstruct #f) + (mutex-unlock! *rundb-mutex*)))) + +;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") +;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no +;; +(define (db:with-db dbstruct run-id r/w proc . params) + (let* ((dbdat (if (vector? dbstruct) + (db:get-db dbstruct run-id) + dbstruct)) ;; cheat, allow for passing in a dbdat + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port))) + (let ((res (apply proc db params))) + (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + res)))) + +;;====================================================================== +;; K E E P F I L E D B I N dbstruct +;;====================================================================== + +;; (define (db:get-filedb dbstruct run-id) +;; (let ((db (vector-ref dbstruct 2))) +;; (if db +;; db +;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) +;; (vector-set! dbstruct 2 fdb) +;; fdb)))) +;; +;; ;; Can also be used to save arbitrary strings +;; ;; +;; (define (db:save-path dbstruct path) +;; (let ((fdb (db:get-filedb dbstruct)))b +;; (filedb:register-path fdb path))) +;; +;; ;; Use to get a path. To get an arbitrary string see next define +;; ;; +;; (define (db:get-path dbstruct id) +;; (let ((fdb (db:get-filedb dbstruct))) +;; (filedb:get-path db id))) + +;; NB// #f => zeroth db with name=main.db +;; +(define (db:dbfile-path run-id) + (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) + (link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (fname (if (eq? run-id 0) "main.db" (conc run-id ".db"))) + (dbdir (conc link-tree-path "/.db/"))) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (exit 1)) + (if (not (directory? dbdir))(create-directory dbdir #t))) + (conc dbdir fname))) + (define (db:set-sync db) - (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) - (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; - ((not syncval) #f) - ((string->number syncval) - (let ((val (string->number syncval))) - (if (member val '(0 1 2)) val #f))) - ((string-match (regexp "yes" #t) syncval) 1) - ((string-match (regexp "no" #t) syncval) 0) - ((string-match (regexp "(off|normal|full)" #t) syncval) syncval) - (else - (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) - #f)))) - (if val - (begin - (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val) - (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) - -(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") - (exit)))) - (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) - (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes - (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) + (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) + (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) + +;; open an sql database inside a file lock +;; +;; returns: db existed-prior-to-opening +;; +(define (db:lock-create-open fname initproc) + (if (file-exists? fname) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + db) + (let* ((parent-dir (pathname-directory fname)) + (dir-writable (file-write-access? parent-dir))) + (if dir-writable + (let ((exists (file-exists? fname)) + (lock (obtain-dot-lock fname 1 5 10)) + (db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not exists)(initproc db)) + (release-dot-lock fname) + db) + (begin + (debug:print 0 "ERROR: no such db in non-writable dir " fname) + (sqlite3:open-database fname)))))) + +;; This routine creates the db. It is only called if the db is not already opened +;; +(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let* ((local (dbr:dbstruct-get-local dbstruct)) + (rdb (if local + (dbr:dbstruct-get-localdb dbstruct run-id) + (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) + (if (or rdb + do-not-open) + rdb + (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) + (dbexists (file-exists? dbpath)) + (inmem (if local #f (db:open-inmem-db))) + (refdb (if local #f (db:open-inmem-db))) + (db (db:lock-create-open dbpath ;; this is the database physically on disk + (lambda (db) + (handle-exceptions + exn + (begin + (release-dot-lock dbpath) + (if (> attemptnum 2) + (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) + (db:initialize-run-id-db db) + (sqlite3:execute + db + "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" + (* run-id 30000) ;; allow for up to 30k tests per run + run-id) + ;; do a dummy query to test that the table exists and the db is truly readable + (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) + )))) ;; add strings db to rundb, not in use yet + ;; )) ;; (sqlite3:open-database dbpath)) + (olddb (if *megatest-db* + *megatest-db* + (let ((db (db:open-megatest-db))) + (set! *megatest-db* db) + db))) + (write-access (file-write-access? dbpath)) + ;; (handler (make-busy-timeout 136000)) + ) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) ;; only unset so other db's also can use this control + (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) + (dbr:dbstruct-set-inuse! dbstruct #t) + (dbr:dbstruct-set-olddb! dbstruct olddb) + ;; (dbr:dbstruct-set-run-id! dbstruct run-id) + (if local + (begin + (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... + db) + (begin + (dbr:dbstruct-set-inmem! dbstruct inmem) + (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context + (db:sync-tables db:sync-tests-only db inmem) + (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) + (dbr:dbstruct-set-refdb! dbstruct refdb) + (db:sync-tables db:sync-tests-only db refdb) + ;; sync once more to deal with delays + (db:sync-tables db:sync-tests-only db inmem) + (db:sync-tables db:sync-tests-only db refdb) + inmem)))))) + +;; This routine creates the db. It is only called if the db is not already ls opened +;; +(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((mdb (dbr:dbstruct-get-main dbstruct))) + (if mdb + mdb + (let* ((dbpath (db:dbfile-path 0)) + (dbexists (file-exists? dbpath)) + (db (db:lock-create-open dbpath db:initialize-main-db)) + (olddb (db:open-megatest-db)) + (write-access (file-write-access? dbpath)) + (dbdat (cons db dbpath))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (dbr:dbstruct-set-main! dbstruct dbdat) + (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) + dbdat)))) + +;; Make the dbstruct, setup up auxillary db's and call for main db at least once +;; +(define (db:setup run-id #!key (local #f)) + (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dbstruct (make-dbr:dbstruct path: dbdir local: local))) + dbstruct)) + +;; Open the classic megatest.db file in toppath +;; +(define (db:open-megatest-db) + (let* ((dbpath (conc *toppath* "/megatest.db")) + (dbexists (file-exists? dbpath)) + (db (db:lock-create-open dbpath + (lambda (db) + (db:initialize-main-db db) + (db:initialize-run-id-db db)))) + (write-access (file-write-access? dbpath))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (cons db dbpath))) + +;; sync run to disk if touched +;; +(define (db:sync-touched dbstruct run-id #!key (force-sync #f)) + (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) + (stime (dbr:dbstruct-get-stime dbstruct)) + (rundb (dbr:dbstruct-get-rundb dbstruct)) + (inmem (dbr:dbstruct-get-inmem dbstruct)) + (maindb (dbr:dbstruct-get-main dbstruct)) + (refdb (dbr:dbstruct-get-refdb dbstruct)) + (olddb (dbr:dbstruct-get-olddb dbstruct)) + ;; (runid (dbr:dbstruct-get-run-id dbstruct)) + ) + (debug:print-info 4 "Syncing for run-id: " run-id) + (mutex-lock! *http-mutex*) + (if (eq? run-id 0) + ;; runid equal to 0 is main.db + (if maindb + (if (or (not (number? mtime)) + (not (number? stime)) + (> mtime stime) + force-sync) + (begin + (db:delay-if-busy maindb) + (db:delay-if-busy olddb) + (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) + (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + num-synced) + 0)) + (begin + ;; this can occur when using local access (i.e. not in a server) + ;; need a flag to turn it off. + ;; + (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") + 0)) + ;; any other runid is a run + (if (or (not (number? mtime)) + (not (number? stime)) + (> mtime stime) + force-sync) + (begin + (db:delay-if-busy rundb) + (db:delay-if-busy olddb) + (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) + (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + (mutex-unlock! *http-mutex*) + num-synced) + (begin + (mutex-unlock! *http-mutex*) + 0)))))) + +(define (db:close-main dbstruct) + (let ((maindb (dbr:dbstruct-get-main dbstruct))) + (if maindb + (begin + (sqlite3:finalize! (db:dbdat-get-db maindb)) + (dbr:dbstruct-set-main! dbstruct #f))))) + +(define (db:close-run-db dbstruct run-id) + (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) + (if (and rdb + (sqlite3:database? rdb)) + (begin + (sqlite3:finalize! rdb) + (dbr:dbstruct-set-localdb! dbstruct run-id #f) + (dbr:dbstruct-set-inmem! dbstruct #f))))) + +;; close all opened run-id dbs +(define (db:close-all dbstruct) + ;; finalize main.db + (db:sync-touched dbstruct 0 force-sync: #t) + ;;(common:db-block-further-queries) + ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? + + (db:close-main dbstruct) + + (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) + (if (hash-table? locdbs) + (for-each (lambda (run-id) + (db:close-run-db dbstruct run-id)) + (hash-table-keys locdbs)))) + + ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) + ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) + ;; (if local + ;; (for-each + ;; (lambda (dbdat) + ;; (let ((db (db:dbdat-get-db dbdat))) + ;; (if (sqlite3:database? db) + ;; (begin + ;; (sqlite3:interrupt! db) + ;; (sqlite3:finalize! db #t))))) + ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized + ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) + ;; (thread-sleep! 3) + ;; (if (and rundb + ;; (sqlite3:database? rundb)) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") + ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (debug:print 0 " db: " rundb) + ;; (print-call-chain (current-error-port)) + ;; #f) + ;; (sqlite3:interrupt! rundb) + ;; (sqlite3:finalize! rundb #t)))) + ;; ;; (mutex-unlock! *db-sync-mutex*) + ) + +(define (db:open-inmem-db) + (let* ((db (sqlite3:open-database ":memory:")) + (handler (make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) - (if (not dbexists) - (db:initialize db)) - (db:set-sync db) - db)) + (db:initialize-run-id-db db) + (cons db #f))) + +;; just tests, test_steps and test_data tables +(define db:sync-tests-only + (list + ;; (list "strs" + ;; '("id" #f) + ;; '("str" #f)) + (list "tests" + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f)) + (list "test_data" + '("id" #f) + '("test_id" #f) + '("category" #f) + '("variable" #f) + '("value" #f) + '("expected" #f) + '("tol" #f) + '("units" #f) + '("comment" #f) + '("status" #f) + '("type" #f)))) + +;; needs db to get keys, this is for syncing all tables +;; +(define (db:sync-main-list db) + (let ((keys (db:get-keys db))) + (list + (list "keys" + '("id" #f) + '("fieldname" #f) + '("fieldtype" #f)) + (list "metadat" '("var" #f) '("val" #f)) + (append (list "runs" + '("id" #f)) + (map (lambda (k)(list k #f)) + (append keys + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))) + (list "test_meta" + '("id" #f) + '("testname" #f) + '("owner" #f) + '("description" #f) + '("reviewed" #f) + '("iterated" #f) + '("avg_runtime" #f) + '("avg_disk" #f) + '("tags" #f) + '("jobgroup" #f))))) + +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; db's are dbdat's +;; +(define (db:sync-tables tbls fromdb todb . slave-dbs) + (mutex-lock! *db-sync-mutex*) + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) + (for-each (lambda (dbdat) + (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) + (cons todb slave-dbs)) + (if *server-run* ;; we are inside a server + (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. + (exit 1))) + (cond + ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) + ((not (sqlite3:database? (db:dbdat-get-db fromdb))) + (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + ((not (sqlite3:database? (db:dbdat-get-db todb))) + (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (else + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds)) + (tot-count 0)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (fromdats '()) + (totrecords 0) + (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) + (todat (make-hash-table)) + (count 0)) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat)) + (if (> (length fromdat) batch-len) + (begin + (set! fromdats (cons fromdat fromdats)) + (set! fromdat '()) + (set! totrecords (+ totrecords 1))))) + (db:dbdat-get-db fromdb) + full-sel) + + (debug:print-info 2 "found " totrecords " records to sync") + + ;; read the target table + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + (db:dbdat-get-db todb) + full-sel) + + ;; first pass implementation, just insert all changed rows + (for-each + (lambda (targdb) + (let* ((db (db:dbdat-get-db targdb)) + (stmth (sqlite3:prepare db full-ins))) + ;; (db:delay-if-busy targdb) ;; NO WAITING + (for-each + (lambda (fromdat-lst) + (sqlite3:with-transaction + db + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) + fromdat-lst)) + )) + fromdats) + (sqlite3:finalize! stmth))) + (append (list todb) slave-dbs)))) + tbls) + (let* ((runtime (- (current-milliseconds) start-time)) + (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (if should-print (debug:print 0 "INFO: db sync, total run time " runtime " ms")) + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)) + (if (> count 0) + (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count)))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count))) + (mutex-unlock! *db-sync-mutex*))) + +;; options: +;; +;; 'killservers - kills all servers +;; 'dejunk - removes junk records +;; 'adj-testids - move test-ids into correct ranges +;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db +;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db +;; 'closeall - close all opened dbs +;; +;; run-ids: '(1 2 3 ...) or #f (for all) +;; +(define (db:multi-db-sync run-ids . options) + (let* ((toppath (launch:setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) + (mtdb (if toppath (db:open-megatest-db))) + (run-ids (if run-ids + run-ids + (if toppath (begin + (db:delay-if-busy mtdb) + (db:get-all-run-ids mtdb))))) + (tdbdat (tasks:open-db)) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + + ;; kill servers + (if (member 'killservers options) + (for-each + (lambda (server) + (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") + (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) + servers)) + + ;; clear out junk records + ;; + (if (member 'dejunk options) + (begin + (db:delay-if-busy mtdb) + (db:clean-up mtdb))) + + ;; adjust test-ids to fit into proper range + ;; + (if (member 'adj-testids options) + (begin + (db:delay-if-busy mtdb) + (db:prep-megatest.db-for-migration mtdb))) + + ;; sync runs, test_meta etc. + ;; + (if (member 'old2new options) + (begin + (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (for-each + (lambda (run-id) + (db:delay-if-busy mtdb) + (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") + (db:replace-test-records dbstruct run-id testrecs) + (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) + run-ids))) + + ;; now ensure all newdb data are synced to megatest.db + (if (member 'new2old options) + (for-each + (lambda (run-id) + (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) + (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + ;; (db:delay-if-busy frundb) + ;; (db:delay-if-busy mtdb) + (if (eq? run-id 0) + (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) + (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)))) + (cons 0 run-ids))) + ;; (db:close-all dbstruct) + ;; (sqlite3:finalize! mdb) + )) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (let* ((db (if idb - (if (procedure? idb) - (idb) - idb) - (open-db))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - (debug:print-info 11 "open-run-close-no-exception-handling END" ) - res)) + (if (or *db-write-access* + (not (member proc *db:all-write-procs*))) + (let* ((db (cond + ((pair? idb) (db:dbdat-get-db idb)) + ((sqlite3:database? idb) idb) + ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! dbstruct)) + (debug:print-info 11 "open-run-close-no-exception-handling END" ) + res) + #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn - (begin - (debug:print 0 "EXCEPTION: database probably overloaded?") - (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain) - (thread-sleep! (random 120)) - (debug:print-info 0 "trying db call one more time....") - (apply open-run-close-no-exception-handling proc idb params)) + (let ((sleep-time (random 30)) + (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (case err-status + ((busy) + (thread-sleep! sleep-time)) + (else + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain (current-error-port)) + (thread-sleep! sleep-time) + (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) + (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) -;; (define open-run-close open-run-close-exception-handling) -(define open-run-close open-run-close-no-exception-handling) - -(define *global-delta* 0) -(define *last-global-delta-printed* 0) - -(define (open-run-close-measure proc idb . params) - (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params) - (let* ((start-ms (current-milliseconds)) - (db (if idb idb (open-db))) - (throttle (string->number (config-lookup *configdat* "setup" "throttle")))) - ;; (db:set-sync db) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - ;; scale by 10, average with current value. - (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) - (if throttle throttle 0.01))) - 2)) - (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit - (begin - (debug:print-info 1 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "open-run-close-measure END" ) - res)) - -(define (db:initialize db) - (debug:print-info 11 "db:initialize START") +;; (define open-run-close +(define open-run-close open-run-close-exception-handling) + ;; open-run-close-no-exception-handling +;; open-run-close-exception-handling) +;;) + +(define (db:initialize-main-db dbdat) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (config-get-fields configdat)) + (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) - (fieldstr (keys->key/field keys))) + (fieldstr (keys->key/field keys)) + (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) - (let ((keyn (vector-ref key 0))) + (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") - (system (conc "rm -f " dbpath)) + (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) - ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") - (db:set-sync db) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " - fieldstr (if havekeys "," "") - "runname TEXT," - "state TEXT DEFAULT ''," - "status TEXT DEFAULT ''," - "owner TEXT DEFAULT ''," - "event_time TIMESTAMP," - "comment TEXT DEFAULT ''," - "fail_count INTEGER DEFAULT 0," - "pass_count INTEGER DEFAULT 0," - "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - (sqlite3:execute db - "CREATE TABLE IF NOT EXISTS tests - (id INTEGER PRIMARY KEY, - run_id INTEGER, - testname TEXT, - host TEXT DEFAULT 'n/a', - cpuload REAL DEFAULT -1, - diskfree INTEGER DEFAULT -1, - uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', - item_path TEXT DEFAULT '', - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'FAIL', - attemptnum INTEGER DEFAULT 0, - final_logf TEXT DEFAULT 'logs/final.log', - logdat BLOB, - run_duration INTEGER DEFAULT 0, - comment TEXT DEFAULT '', - event_time TIMESTAMP, - fail_count INTEGER DEFAULT 0, - pass_count INTEGER DEFAULT 0, - archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") - (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps - (id INTEGER PRIMARY KEY, - test_id INTEGER, - stepname TEXT, - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'n/a', - event_time TIMESTAMP, - comment TEXT DEFAULT '', - logfile TEXT DEFAULT '', - CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (for-each (lambda (key) + (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + keys) + (sqlite3:execute db (conc + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " + fieldstr (if havekeys "," "") " + runname TEXT DEFAULT 'norun', + state TEXT DEFAULT '', + status TEXT DEFAULT '', + owner TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + comment TEXT DEFAULT '', + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, @@ -219,11 +769,73 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + ;; cannot use db:set-var since it will deadlock, hardwire the code here + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version) + (debug:print-info 11 "db:initialize END"))))) + +;;====================================================================== +;; R U N S P E C I F I C D B +;;====================================================================== + +(define (db:initialize-run-id-db db) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (id INTEGER PRIMARY KEY, + run_id INTEGER DEFAULT -1, + testname TEXT DEFAULT 'noname', + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT '/tmp/badname', + shortdir TEXT DEFAULT '/tmp/badname', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'FAIL', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat TEXT DEFAULT '', + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (id INTEGER PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + event_time TIMESTAMP, + comment TEXT DEFAULT '', + logfile TEXT DEFAULT '', + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") + ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data + ;; (id INTEGER PRIMARY KEY, + ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), + ;; iterated TEXT DEFAULT '', + ;; avg_runtime REAL DEFAULT -1, + ;; avg_disk REAL DEFAULT -1, + ;; tags TEXT DEFAULT '', + ;; jobgroup TEXT DEFAULT 'default', + ;; CONSTRAINT test_meta_constraint UNIQUE (testname));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -231,244 +843,217 @@ units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Must do this *after* running patch db !! No more. - (db:set-var db "MEGATEST_VERSION" megatest-version) - (debug:print-info 11 "db:initialize END") - )) - -;;====================================================================== -;; T E S T S P E C I F I C D B -;;====================================================================== - -;; Create the sqlite db for the individual test(s) -(define (open-test-db testpath) - (debug:print-info 11 "open-test-db " testpath) - (if (and testpath - (directory? testpath) - (file-read-access? testpath)) - (let* ((dbpath (conc testpath "/testdat.db")) - (dbexists (file-exists? dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: problem accessing test db " testpath ", you probably should clean and re-run this test" - ((condition-property-accessor 'exn 'message) exn)) - #f) - (set! db (sqlite3:open-database dbpath))) - (sqlite3:set-busy-handler! db handler) - (if (not dbexists) - (begin - (sqlite3:execute db "PRAGMA synchronous = FULL;") - (debug:print-info 11 "Initialized test database " dbpath) - (db:testdb-initialize db))) - ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 "open-test-db END (sucessful)" testpath) - ;; now let's test that everything is correct - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: problem accessing test db " testpath ", you probably should clean and re-run this test" - ((condition-property-accessor 'exn 'message) exn)) - #f) - ;; Is there a cheaper single line operation that will check for existance of a table - ;; and raise an exception ? - (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) - db) - (begin - (debug:print-info 11 "open-test-db END (unsucessful)" testpath) - #f))) - -;; find and open the testdat.db file for an existing test -(define (db:open-test-db-by-test-id db test-id) - (let* ((test-path (cdb:remote-run db:test-get-rundir-from-test-id db test-id))) - (debug:print 3 "TEST PATH: " test-path) - (open-test-db test-path))) - -(define (db:testdb-initialize db) - (debug:print 11 "db:testdb-initialize START") - (for-each - (lambda (sqlcmd) - (sqlite3:execute db sqlcmd)) - (list "CREATE TABLE IF NOT EXISTS test_rundat ( - id INTEGER PRIMARY KEY, - update_time TIMESTAMP, - cpuload INTEGER DEFAULT -1, - diskfree INTEGER DEFAULT -1, - diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);" - "CREATE TABLE IF NOT EXISTS test_data ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - type TEXT DEFAULT '', - CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" - "CREATE TABLE IF NOT EXISTS test_steps ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - stepname TEXT, - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'n/a', - event_time TIMESTAMP, - comment TEXT DEFAULT '', - logfile TEXT DEFAULT '', - CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" - ;; test_meta can be used for handing commands to the test - ;; e.g. KILLREQ - ;; the ackstate is set to 1 once the command has been completed - "CREATE TABLE IF NOT EXISTS test_meta ( - id INTEGER PRIMARY KEY, - var TEXT, - val TEXT, - ackstate INTEGER DEFAULT 0, - CONSTRAINT metadat_constraint UNIQUE (var));")) - (debug:print 11 "db:testdb-initialize END")) + ;; Why use FULL here? This data is not that critical + ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);"))) + db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) + (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) + )) db)) (define (db:log-local-event . loglst) - (let ((logline (apply conc loglst)) - (pwd (current-directory)) - (cmdline (string-intersperse (argv) " ")) - (pid (current-process-id))) - (db:log-event logline pwd cmdline pid))) + (let ((logline (apply conc loglst))) + (db:log-event logline))) -(define (db:log-event logline pwd cmdline pid) +(define (db:log-event logline) (let ((db (open-logging-db))) - (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory)(string-intersperse (argv) " ")(current-process-id)) + (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" + logline + (current-directory) + (string-intersperse (argv) " ") + (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== -;; TODO: -;; put deltas into an assoc list with version numbers -;; apply all from last to current -;;====================================================================== -(define (patch-db db) - (handle-exceptions - exn - (begin - (print "Exception: " exn) - (print "ERROR: Possible out of date schema, attempting to add table metadata...") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (if (not (db:get-var db "MEGATEST_VERSION")) - (db:set-var db "MEGATEST_VERSION" 1.17))) - (let ((mver (db:get-var db "MEGATEST_VERSION")) - (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP, - iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, - tags TEXT DEFAULT '', - CONSTRAINT test_meta_constraint UNIQUE (testname));")) - (print "Current schema version: " mver " current megatest version: " megatest-version) - (cond - ((not mver) - (print "Adding megatest-version to metadata") ;; Need to recreate the table - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.17) - (patch-db)) - ((< mver 1.21) - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied - (sqlite3:execute db test-meta-def) - ;(for-each - ; (lambda (stmt) - ; (sqlite3:execute db stmt)) - ; (list - ; "ALTER TABLE tests ADD COLUMN first_err TEXT;" - ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;" - ; )) - (patch-db)) - ((< mver 1.24) - (db:set-var db "MEGATEST_VERSION" 1.24) - (sqlite3:execute db "DROP TABLE IF EXISTS test_data;") - (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;") - (sqlite3:execute db test-meta-def) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - CONSTRAINT test_data UNIQUE (test_id,category,variable));") - (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") - (patch-db)) - ((< mver 1.27) - (db:set-var db "MEGATEST_VERSION" 1.27) - (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") - (patch-db)) - ((< mver 1.29) - (db:set-var db "MEGATEST_VERSION" 1.29) - (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) - ((< mver 1.36) - (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) - ((< mver 1.37) - (db:set-var db "MEGATEST_VERSION" 1.37) - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) - ((< mver megatest-version) - (db:set-var db "MEGATEST_VERSION" megatest-version)))))) - -;;====================================================================== -;; meta get and set vars +;; D B U T I L S +;;====================================================================== + +;;====================================================================== +;; M A I N T E N A N C E +;;====================================================================== + +;; select end_time-now from +;; (select testname,item_path,event_time+run_duration as +;; end_time,strftime('%s','now') as now from tests where state in +;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); + +(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (incompleted '()) + (oldlaunched '()) + (toplevels '()) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime (if (and deadtime-str + (string->number deadtime-str)) + (string->number deadtime-str) + 7200))) ;; two hours + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id)) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" + run-id) + + (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + (db:delay-if-busy dbdat) + (let* (;; (min-incompleted (filter (lambda (x) + ;; (let* ((testpath (cadr x)) + ;; (tdatpath (conc testpath "/testdat.db")) + ;; (dbexists (file-exists? tdatpath))) + ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete + ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim + ;; incompleted)) + (min-incompleted-ids (map car incompleted)) ;; do 'em all + (all-ids (append min-incompleted-ids (map car oldlaunched)))) + (if (> (length all-ids) 0) + (begin + (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (sqlite3:execute + db + (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" + (string-intersperse (map conc all-ids) ",") + ");"))))) + + ;; Now do rollups for the toplevel tests + ;; + (db:delay-if-busy dbdat) + (for-each + (lambda (toptest) + (let ((test-name (list-ref toptest 3))) +;; (run-id (list-ref toptest 5))) + (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) + toplevels))) + +;; Clean out old junk and vacuum the database +;; +;; Ultimately do something like this: +;; +;; 1. Look at test records either deleted or part of deleted run: +;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' +;; b. If test dir gone, delete the test record +;; 2. Look at run records +;; a. If have tests that are not deleted, set state='unknown' +;; b. .... +;; +(define (db:clean-up dbdat) + (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + (let* ((db (db:dbdat-get-db dbdat)) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (statements + (map (lambda (stmt) + (sqlite3:prepare db stmt)) + (list + ;; delete all tests that belong to runs that are 'deleted' + "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" + ;; delete all tests that are 'DELETED' + "DELETE FROM tests WHERE state='DELETED';" + ;; delete all tests that have no run + "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" + ;; delete all runs that are state='deleted' + "DELETE FROM runs WHERE state='deleted';" + ;; delete empty runs + "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" + )))) + (db:delay-if-busy dbdat) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 "Records count before clean: " tot)) + count-stmt) + (map sqlite3:execute statements) + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 "Records count after clean: " tot)) + count-stmt))) + (map sqlite3:finalize! statements) + (sqlite3:finalize! count-stmt) + ;; (db:find-and-mark-incomplete db) + (db:delay-if-busy dbdat) + (sqlite3:execute db "VACUUM;"))) + +;;====================================================================== +;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* -(define (db:get-var db var) - (debug:print-info 11 "db:get-var START " var) +;; +;; Operates on megatestdb +;; +(define (db:get-var dbstruct var) (let* ((start-ms (current-milliseconds)) (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) (if t (string->number t) t))) - (res #f)) + (res #f) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) - db "SELECT val FROM metadat WHERE var=?;" var) + db + "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. @@ -477,57 +1062,96 @@ 2)) (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit (begin (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "db:get-var END " var " val=" res) res)) -(define (db:set-var db var val) - (debug:print-info 11 "db:set-var START " var " " val) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val) - (debug:print-info 11 "db:set-var END " var " " val)) - -(define (db:del-var db var) - (debug:print-info 11 "db:del-var START " var) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) - (debug:print-info 11 "db:del-var END " var)) - -;; use a global for some primitive caching, it is just silly to re-read the db -;; over and over again for the keys since they never change - -(define (db:get-keys db) +(define (db:set-var dbstruct var val) + (let ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + +(define (db:del-var dbstruct var) + ;; (db:delay-if-busy) + (db:with-db dbstruct #f #t + (lambda (db) + (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) + +;; use a global for some primitive caching, it is just silly to +;; re-read the db over and over again for the keys since they never +;; change + +;; why get the keys from the db? why not get from the *configdat* +;; using keys:config-get-fields? + +(define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) - (debug:print-info 11 "db:get-keys START (cache miss)") - (sqlite3:for-each-row - (lambda (key keytype) - (set! res (cons (vector key keytype) res))) - db - "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (key) + (set! res (cons key res))) + db + "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) - (debug:print-info 11 "db:get-keys END (cache miss)") res))) +;; look up values in a header/data structure (define (db:get-value-by-header row header field) - (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (vector-ref row n) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) +;; Accessors for the header/data structure +;; get rows and header from +(define (db:get-header vec)(vector-ref vec 0)) +(define (db:get-rows vec)(vector-ref vec 1)) + ;;====================================================================== ;; R U N S ;;====================================================================== + +(define (db:get-run-name-from-id dbstruct run-id) + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (runname) + (set! res runname)) + db + "SELECT runname FROM runs WHERE id=?;" + run-id) + res)))) + +(define (db:get-run-key-val dbstruct run-id key) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + (conc "SELECT " key " FROM runs WHERE id=?;") + run-id) + res)))) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) - (let* ((header (append (map key:get-fieldname keys) - remfields)) + (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) ;; make a query (fieldname like 'patt1' OR fieldname @@ -541,1393 +1165,1526 @@ (if (null? patts) '("") patts)) comparator))) + +;; register a test run with the db, this accesses the main.db and does NOT +;; use server api +;; +(define (db:register-run dbstruct keyvals runname state status user) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (keys (map car keyvals)) + (keystr (keys->keystr keys)) + (comma (if (> (length keys) 0) "," "")) + (andstr (if (> (length keys) 0) " AND " "")) + (valslots (keys->valslots keys)) ;; ?,?,? ... + (allvals (append (list runname state status user) (map cadr keyvals))) + (qryvals (append (list runname) (map cadr keyvals))) + (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") + (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" + (let ((res #f)) + (db:delay-if-busy dbdat) + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + allvals) + (db:delay-if-busy dbdat) + (apply sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) + ;(debug:print 4 "qry: " qry) + qry) + qryvals) + (db:delay-if-busy dbdat) + (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + res) + (begin + (debug:print 0 "ERROR: Called without all necessary keys") + #f)))) + ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; -(define (db:get-runs db runpatt count offset keypatts) +(define (db:get-runs dbstruct runpatt count offset keypatts) (let* ((res '()) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ","))) + (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " - ;; Generate: " AND x LIKE 'keypatt' ..." - (if (null? keypatts) "" - (conc " AND " + ;; Generate: " AND x LIKE 'keypatt' ..." + (if (null? keypatts) "" + (conc " AND " (string-join (map (lambda (keypatt) (let ((key (car keypatt)) (patt (cadr keypatt))) (db:patt->like key patt))) keypatts) " AND "))) - " ORDER BY event_time DESC " - (if (number? count) - (conc " LIMIT " count) - "") - (if (number? offset) - (conc " OFFSET " offset) - "")))) + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) - db - qrystr - ) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (cons (apply vector a x) res))) + db + qrystr + ))) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) +;; db:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; to extract info from the structure returned +;; +;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames +;; +(define (db:get-run-ids-matching dbstruct keynames target res) +;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) + (keystr (car tmp)) + (header (cadr tmp)) + (res '()) + (key-patt "") + (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) + (qry-str #f) + (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (patt (cadr keyval)) + (fulkey (conc ":" key)) + (wildtype (if (substring-index "%" patt) "like" "glob"))) + (if patt + (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) + (begin + (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) + (exit 6))))) + keyvals) + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " + (if limit (conc " LIMIT " limit) "") + (if offset (conc " OFFSET " offset) "") + ";")) + (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + (db:get-db dbstruct #f) + qry-str + runnamepatt))) + (vector header res))) + +;; Get all targets from the db +;; +(define (db:get-targets dbstruct) + (let* ((res '()) + (keys (db:get-keys dbstruct)) + (header keys) ;; (map key:get-fieldname keys)) + (keystr (keys->keystr keys)) + (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) + (seen (make-hash-table))) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (let ((targ (cons a x))) + (if (not (hash-table-ref/default seen targ #f)) + (begin + (hash-table-set! seen targ #t) + (set! res (cons (apply vector targ) res)))))) + db + qrystr) + (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) + (vector header res))))) + ;; just get count of runs -(define (db:get-num-runs db runpatt) - (let ((numruns 0)) - (debug:print-info 11 "db:get-num-runs START " runpatt) - (sqlite3:for-each-row - (lambda (count) - (set! numruns count)) +(define (db:get-num-runs dbstruct runpatt) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((numruns 0)) + (debug:print-info 11 "db:get-num-runs START " runpatt) + (sqlite3:for-each-row + (lambda (count) + (set! numruns count)) + db + "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) + (debug:print-info 11 "db:get-num-runs END " runpatt) + numruns)))) + +(define (db:get-all-run-ids dbstruct) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (let ((run-ids '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! run-ids (cons run-id run-ids))) + db + "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") + (reverse run-ids))))) + +;; get some basic run stats +;; +;; ( (runname (( state count ) ... )) +;; ( ... +(define (db:get-run-stats dbstruct) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (totals (make-hash-table)) + (curr (make-hash-table)) + (res '()) + (runs-info '())) + ;; First get all the runname/run-ids + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (run-id runname) + (set! runs-info (cons (list run-id runname) runs-info))) db - "SELECT COUNT(id) FROM runs WHERE runname LIKE ?;" runpatt) - (debug:print-info 11 "db:get-num-runs END " runpatt) - numruns)) + "SELECT id,runname FROM runs WHERE state != 'deleted';") + ;; for each run get stats data + (for-each + (lambda (run-info) + ;; get the net state/status counts for this run + (let* ((run-id (car run-info)) + (run-name (cadr run-info))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (state status count) + (let ((netstate (if (equal? state "COMPLETED") status state))) + (if (string? netstate) + (begin + (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) + (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) + db + "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + ;; add the per run counts to res + (for-each (lambda (state) + (set! res (cons (list run-name state (hash-table-ref curr state)) res))) + (sort (hash-table-keys curr) string>=)) + (set! curr (make-hash-table)))))) + runs-info) + (for-each (lambda (state) + (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) + (sort (hash-table-keys totals) string>=)) + res)) -;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -(define (db:get-run-info db run-id) +;; db:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; to extract info from the structure returned +;; +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) + (keystr (car tmp)) + (header (cadr tmp)) + (res '()) + (key-patt "") + (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) + (qry-str #f) + (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (patt (cadr keyval)) + (fulkey (conc ":" key)) + (wildtype (if (substring-index "%" patt) "like" "glob"))) + (if patt + (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) + (begin + (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) + (exit 6))))) + keyvals) + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " + (if limit (conc " LIMIT " limit) "") + (if offset (conc " OFFSET " offset) "") + ";")) + (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + db + qry-str + runnamepatt))) + (vector header res))) + +;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +(define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) - (let* ((res #f) - (keys (db:get-keys db)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) - (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ",")))) - (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (apply vector a x))) - db - (conc "SELECT " keystr " FROM runs WHERE id=?;") - run-id) - (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (let ((finalres (vector header res))) - ;; (hash-table-set! *run-info-cache* run-id finalres) - finalres))) - -(define (db:set-comment-for-run db run-id comment) - (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id) - (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment)) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (res (vector #f #f #f #f)) + (keys (db:get-keys dbstruct)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (header (append keys remfields)) + (keystr (conc (keys->keystr keys) "," + (string-intersperse remfields ",")))) + (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (apply vector a x))) + db + (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") + run-id) + (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (let ((finalres (vector header res))) + ;; (hash-table-set! *run-info-cache* run-id finalres) + finalres))) + +(define (db:set-comment-for-run dbstruct run-id comment) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? -(define (db:delete-run db run-id) - (common:clear-caches) ;; don't trust caches after doing any deletion - (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) - -(define (db:update-run-event_time db run-id) - (debug:print-info 11 "db:update-run-event_time START run-id: " run-id) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id) - (debug:print-info 11 "db:update-run-event_time END run-id: " run-id)) - -(define (db:lock/unlock-run db run-id lock unlock user) - (let ((newlockval (if lock "locked" - (if unlock - "unlocked" - "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" - user (conc newlockval " " run-id)) - (debug:print-info 1 "" newlockval " run number " run-id))) +(define (db:delete-run dbstruct run-id) + ;; First set any related tests to DELETED + (let* ((rdbdat (db:get-db dbstruct run-id)) + (rdb (db:dbdat-get-db rdbdat)) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy rdbdat) + (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") + (sqlite3:execute rdb "DELETE FROM test_steps;") + (sqlite3:execute rdb "DELETE FROM test_data;") + (db:delay-if-busy dbdat) + (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) + +(define (db:update-run-event_time dbstruct run-id) + (db:with-db + dbstruct + #f + #t + (lambda (db) + (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) + +(define (db:lock/unlock-run dbstruct run-id lock unlock user) + (db:with-db + dbstruct + #f + #t + (lambda (db) + (let ((newlockval (if lock "locked" + (if unlock + "unlocked" + "locked")))) ;; semi-failsafe + (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + user (conc newlockval " " run-id)) + (debug:print-info 1 "" newlockval " run number " run-id))))) + +(define (db:set-run-status dbstruct run-id status msg) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (db:delay-if-busy dbdat) + (if msg + (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) + (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) + +(define (db:get-run-status dbstruct run-id) + (let ((res "n/a")) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (status) + (set! res status)) + db + "SELECT status FROM runs WHERE id=?;" + run-id) + res)))) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (db:get-key-val-pairs db run-id) - (let* ((keys (get-keys db)) - (res '())) - (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (list (key:get-fieldname key) key-val) res))) - db qry run-id))) - keys) - (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) - (reverse res))) - -;; get key vals for a given run-id -(define (db:get-key-vals db run-id) - (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) - (if mykeyvals - mykeyvals - (let* ((keys (get-keys db)) - (res '())) - (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) - (let ((final-res (reverse res))) - (hash-table-set! *keyvals* run-id final-res) - final-res))))) - -;; The target is keyval1/keyval2..., cached in *target* as it is used often -(define (db:get-target db run-id) - (let ((mytarg (hash-table-ref/default *target* run-id #f))) - (if mytarg - mytarg - (let* ((keyvals (db:get-key-vals db run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) - (hash-table-set! *target* run-id thekey) - thekey)))) - -;;====================================================================== -;; T E S T S -;;====================================================================== - -(define (db:tests-register-test db run-id test-name item-path) - (debug:print-info 11 "db:tests-register-test START db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (for-each - (lambda (pth) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" - run-id - test-name - pth)) - item-paths) - (debug:print-info 11 "db:tests-register-test END db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - #f)) - -;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN -;; i.e. these lists define what to NOT show. -;; states and statuses are required to be lists, empty is ok -;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run db run-id testpatt states statuses - #!key (not-in #t) - (sort-by #f) ;; 'rundir 'event_time - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - ) - (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) - (let* ((res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if not-in "NOT" "") - " IN ('" - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in "NOT" "") - " IN ('" - (string-intersperse statuses "','") - "')"))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE run_id=? " - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-run qry=" qry) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - run-id - ) - (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) - res)) - -;; get a useful subset of the tests data (used in dashboard -;; use db:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status) - (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path")) - -;; NB // This is get tests for "runs" (note the plural!!) -;; -;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN -;; i.e. these lists define what to NOT show. -;; states and statuses are required to be lists, empty is ok -;; not-in #t = above behaviour, #f = must match -;; run-ids is a list of run-ids or a single number -(define (db:get-tests-for-runs db run-ids testpatt states statuses - #!key (not-in #t) - (sort-by #f) - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time - (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) - (let* ((res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if not-in "NOT" "") - " IN ('" - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in "NOT" "") - " IN ('" - (string-intersperse statuses "','") - "')"))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE " - (if run-ids - (if (list? run-ids) - (conc " run_id in (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "run_id=" run-ids " ")) - " ") ;; #f => run-ids don't filter on run-ids - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-run qry=" qry) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - ) - (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) - res)) - -;; this one is a bit broken BUG FIXME -(define (db:delete-test-step-records db test-id) - ;; Breaking it into two queries for better file access interleaving - (let* ((tdb (db:open-test-db-by-test-id db test-id))) - ;; test db's can go away - must check every time - (if tdb - (begin - (sqlite3:execute tdb "DELETE FROM test_steps;") - (sqlite3:execute tdb "DELETE FROM test_data;") - (sqlite3:finalize! tdb))))) - -;; -(define (db:delete-test-records db tdb test-id #!key (force #f)) - (common:clear-caches) - (if tdb - (begin - (sqlite3:execute tdb "DELETE FROM test_steps;") - (sqlite3:execute tdb "DELETE FROM test_data;"))) - ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) - (if db - (begin - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) - (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) - (if force - (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a' WHERE id=?;" test-id))))) - -(define (db:delete-tests-for-run db run-id) - (common:clear-caches) - (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) - -(define (db:delete-old-deleted-test-records db) - (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timesqlqry testpatt)) - (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " - keystr " AND r.runname LIKE '" runname "' AND " testqry - " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt - "' ORDER BY t.event_time ASC;"))) - (debug:print 3 "qrystr: " qrystr) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - db - qrystr) - res)) - -;; look through tests from matching runs for a file -(define (db:test-get-first-path-matching db keynames target fname) - ;; [refpaths] is the section where references to other megatest databases are stored - (let ((mt-paths (configf:get-section "refpaths")) - (res (db:test-get-paths-matching db keynames target fname))) - (let loop ((pathdat (if (null? paths) #f (car mt-paths))) - (tal (if (null? paths) '()(cdr mt-paths)))) - (if (not (null? res)) - (car res) ;; return first found - (if path - (let* ((db (open-db path: (cadr pathdat))) - (newres (db:test-get-paths-matching db keynames target fname))) - (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) - (sqlite3:finalize! db) - (if (not (null? newres)) - (car newres) - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))))) +(define (db:get-key-val-pairs dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) + (res '()) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons (list key key-val) res))) + db qry run-id))) + keys) + (reverse res))) + +;; get key vals for a given run-id +(define (db:get-key-vals dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) + (res '()) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys) + (let ((final-res (reverse res))) + (hash-table-set! *keyvals* run-id final-res) + final-res))) + +;; The target is keyval1/keyval2..., cached in *target* as it is used often +(define (db:get-target dbstruct run-id) + (let* ((keyvals (db:get-key-vals dbstruct run-id)) + (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) + thekey)) + +;; Get run-ids for runs with same target but different runnames and NOT run-id +;; +(define (db:get-prev-run-ids dbstruct run-id) + (let* ((keyvals (rmt:get-key-val-pairs run-id)) + (kvalues (map cadr keyvals)) + (keys (rmt:get-keys)) + (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) + (let ((prev-run-ids '())) + (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db + (lambda (db) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) + prev-run-ids))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN +;; i.e. these lists define what to NOT show. +;; states and statuses are required to be lists, empty is ok +;; not-in #t = above behaviour, #f = must match +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) + (if (not (number? run-id)) + (begin ;; no need to treat this as an error by default + (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) + ;; (print-call-chain (current-error-port)) + '()) + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (res '()) + ;; if states or statuses are null then assume match all when not-in is false + (states-qry (if (null? states) + #f + (conc " state " + (if not-in + " NOT IN ('" + " IN ('") + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if not-in + " NOT IN ('" + " IN ('") + (string-intersperse statuses "','") + "')"))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (states-qry + (conc " AND " states-qry)) + (statuses-qry + (conc " AND " statuses-qry)) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + " FROM tests WHERE run_id=? AND state != 'DELETED' " + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") + ";" + ))) + (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + db + qry + run-id + ))) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res))))) + +(define (db:test-short-record->norm inrec) + ;; "id,run_id,testname,item_path,state,status" + ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (vector (vector-ref inrec 0) ;; id + (vector-ref inrec 1) ;; run_id + (vector-ref inrec 2) ;; testname + (vector-ref inrec 4) ;; state + (vector-ref inrec 5) ;; status + -1 "" -1 -1 "" "-" + (vector-ref inrec 3) ;; item-path + -1 "-" "-")) + + +(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) + (let* ((res '()) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) + (debug:print-info 8 "db:get-tests-for-run qry=" qry) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + qry + run-id))) + res)) + +(define (db:get-testinfo-state-status dbstruct run-id test-id) + (let ((res #f)) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id))) + res)) + +;; get a useful subset of the tests data (used in dashboard +;; use db:mintests-get-{id ,run_id,testname ...} +;; +(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) + (debug:print 0 "ERROR: BROKN!") + ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +) + +;; get a useful subset of the tests data (used in dashboard +;; +(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path")) + +;; do not use. +;; +(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) + ;; (db:delay-if-busy) + (let ((res '())) + (for-each + (lambda (run-id) + (set! res (append + res + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals)))) + (if run-ids + run-ids + (db:get-all-run-ids dbstruct))) + res)) + +;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs +;; + +(define (db:delete-test-records dbstruct run-id test-id) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat))) + (db:general-call dbdat 'delete-test-step-records (list test-id)) + ;; (db:delay-if-busy) + (db:general-call dbdat 'delete-test-data-records (list test-id)) + (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) + +(define (db:delete-old-deleted-test-records dbstruct) + (let ((run-ids (db:get-all-run-ids dbstruct)) + (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past + (for-each + (lambda (run-id) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timenumber fieldname fields) + (if (null? fields) + #f + (let loop ((hed (car fields)) + (tal (cdr fields)) + (indx 0)) + (if (equal? fieldname hed) + indx + (if (null? tal) + #f + (loop (car tal)(cdr tal)(+ indx 1))))))) + +(define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) + + +;; NOTE: Use db:test-get* to access records +;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. +(define (db:get-all-tests-info-by-run-id dbstruct run-id) + (let* ((dbdat (if (vector? dbstruct) + (db:get-db dbstruct run-id) + dbstruct)) ;; still settling on when to use dbstruct or dbdat + (db (db:dbdat-get-db dbdat)) + (res '())) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum) + res))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") + run-id) + res)) + +(define (db:replace-test-records dbstruct run-id testrecs) + (db:with-db dbstruct run-id #t + (lambda (db) + (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) + (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) + (qry (sqlite3:prepare db qrystr))) + (debug:print 0 "INFO: migrating test records for run with id " run-id) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (rec) + ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") + (apply sqlite3:execute qry (vector->list rec))) + testrecs))) + (sqlite3:finalize! qry))))) + +;; map a test-id into the proper range +;; +(define (db:adj-test-id mtdb min-test-id test-id) + (if (>= test-id min-test-id) + test-id + (let loop ((new-id min-test-id)) + (let ((test-id-found #f)) + (sqlite3:for-each-row + (lambda (id) + (set! test-id-found id)) + (db:dbdat-get-db mtdb) + "SELECT id FROM tests WHERE id=?;" + new-id) + ;; if test-id-found then need to try again + (if test-id-found + (loop (+ new-id 1)) + (begin + (debug:print-info 0 "New test id " new-id " selected for test with id " test-id) + (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) + +;; move test ids into the 30k * run_id range +;; +(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) + (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id) + (let ((min-test-id (* run-id 30000))) + (for-each + (lambda (testrec) + (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) + (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) + testrecs))) + +;; 1. move test ids into the 30k * run_id range +;; 2. move step ids into the 30k * run_id range +;; +(define (db:prep-megatest.db-for-migration mtdb) + (let* ((run-ids (db:get-all-run-ids mtdb))) + (for-each + (lambda (run-id) + (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) + (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) + run-ids))) + +;; Get test data using test_id +(define (db:get-test-info-by-id dbstruct run-id test-id) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") + test-id) + res)))) + +;; Use db:test-get* to access +;; Get test data using test_ids. NB// Only works within a single run!! +;; +(define (db:get-test-info-by-ids dbstruct run-id test-ids) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (apply vector a b) res))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" + (string-intersperse (map conc test-ids) ",") ");")) + res)))) + +(define (db:get-test-info dbstruct run-id testname item-path) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") + test-name item-path) + res)))) + +(define (db:test-get-rundir-from-test-id dbstruct run-id test-id) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (db:first-result-default + db + "SELECT rundir FROM tests WHERE id=?;" + #f ;; default result + test-id)))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute + db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" + test-id teststep-name state-in status-in (current-seconds) + (if comment comment "") + (if logfile logfile ""))))) + +;; db-get-test-steps-for-run +(define (db:get-steps-for-test dbstruct run-id test-id) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let* ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (reverse res))))) + +(define (db:get-steps-data dbstruct run-id test-id) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + db + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (reverse res))))) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== + +;; WARNING: Do NOT call this for the parent test on an iterated test +;; Roll up test_data pass/fail results +;; look at the test_data status field, +;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. +;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored +(define (db:test-data-rollup dbstruct run-id test-id status) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (fail-count 0) + (pass-count 0)) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (fcount pcount) + (set! fail-count fcount) + (set! pass-count pcount)) + db + "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, + (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" + test-id test-id) + ;; Now rollup the counts to the central megatest.db + (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) + ;; if the test is not FAIL then set status based on the fail and pass counts. + (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) + +(define (db:csv->test-data dbstruct run-id test-id csvdata) + (debug:print 4 "test-id " test-id ", csvdata: " csvdata) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (csvlist (csv->list (make-csv-reader + (open-input-string csvdata) + '((strip-leading-whitespace? #t) + (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) + (for-each + (lambda (csvrow) + (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) + (category (list-ref padded-row 0)) + (variable (list-ref padded-row 1)) + (value (any->number-if-possible (list-ref padded-row 2))) + (expected (any->number-if-possible (list-ref padded-row 3))) + (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number + (units (list-ref padded-row 5)) + (comment (list-ref padded-row 6)) + (status (let ((s (list-ref padded-row 7))) + (if (and (string? s)(or (string-match (regexp "^\\s*$") s) + (string-match (regexp "^n/a$") s))) + #f + s))) ;; if specified on the input then use, else calculate + (type (list-ref padded-row 8))) + ;; look up expected,tol,units from previous best fit test if they are all either #f or '' + (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) + + (if (and (or (not expected)(equal? expected "")) + (or (not tol) (equal? expected "")) + (or (not units) (equal? expected ""))) + (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable))) + (set! expected new-expected) + (set! tol new-tol) + (set! units new-units))) + + (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; calculate status if NOT specified + (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers + (if (number? tol) ;; if tol is a number then we do the standard comparison + (let* ((max-val (+ expected tol)) + (min-val (- expected tol)) + (result (and (>= value min-val)(<= value max-val)))) + (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) + (set! status (if result "pass" "fail"))) + (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. + (case (string->symbol tol) ;; tol should be >, <, >=, <= + ((>) (if (> value expected) "pass" "fail")) + ((<) (if (< value expected) "pass" "fail")) + ((>=) (if (>= value expected) "pass" "fail")) + ((<=) (if (<= value expected) "pass" "fail")) + (else (conc "ERROR: bad tol comparator " tol)))))) + (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + (db:delay-if-busy dbdat) + (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units (if comment comment "") status type))) + csvlist))) + +;;====================================================================== +;; Misc. test related queries +;;====================================================================== + +(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (row-ids '()) + (keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + ;; (testqry (tests:match->sqlqry testpatt)) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + (sqlite3:for-each-row + (lambda (rid) + (set! row-ids (cons rid row-ids))) + runsqry) + (sqlite3:finalize! runsqry) + row-ids)) + +(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) + (let* ((testqry (tests:match->sqlqry testpatt)) + (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (p) + (set! res (cons p res))) + db + tstsqry) + res)))) + +(define (db:test-toplevel-num-items dbstruct run-id testname) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-items) + (set! res num-items)) + db + "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" + run-id + testname) + res)))) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq (define (db:obj->string obj) (case *transport-type* - ((fs) obj) - ((http) + ;; ((fs) obj) + ((http fs) (string-substitute (regexp "=") "_" - (base64:base64-encode (with-output-to-string (lambda ()(serialize obj)))) + (base64:base64-encode + (z3:encode-buffer + (with-output-to-string + (lambda ()(serialize obj))))) #t)) ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* - ((fs) msg) - ((http) - (with-input-from-string - (base64:base64-decode - (string-substitute - (regexp "_") "=" msg #t)) - (lambda ()(deserialize)))) - ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) - (else msg))) - -(define (cdb:use-non-blocking-mode proc) - (set! *client-non-blocking-mode* #t) - (let ((res (proc))) - (set! *client-non-blocking-mode* #f) - res)) - -;; params = 'target cached remparams -;; -;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime -;; -;; cdb:client-call is the unified interface to all the transports. It dispatches the -;; query to a server routine (e.g. server:client-send-recieve) that -;; transports the data to the server where it is passed to db:process-queue-item -;; which either returns the data to the calling server routine or -;; directly calls the returning procedure (e.g. zmq). -;; -(define (cdb:client-call serverdat qtype immediate numretries . params) - (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params) - (case *transport-type* - ((fs) - (let ((packet (vector "na" qtype immediate "na" params 0))) - (fs:process-queue-item packet))) - ((http) - (let* ((client-sig (client:get-signature)) - (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) - (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params)))) - (debug:print-info 11 "zdat=" zdat) - (let* ((res #f) - (rawdat (http-transport:client-send-receive serverdat zdat)) - (tmp #f)) - (debug:print-info 11 "Sent " zdat ", received " rawdat) - (set! tmp (db:string->obj rawdat)) - (vector-ref tmp 2)))) - ((zmq) - (handle-exceptions - exn - (begin - (thread-sleep! 5) - (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) - (let* ((push-socket (vector-ref serverdat 0)) - (sub-socket (vector-ref serverdat 1)) - (client-sig (client:get-signature)) - (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) - (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params)))) - (res #f) - (send-receive (lambda () - (debug:print-info 11 "sending message") - (send-message push-socket zdat) - (debug:print-info 11 "message sent") - (let loop () - ;; get the sender info - ;; this should match (client:get-signature) - ;; we will need to process "all" messages here some day - (receive-message* sub-socket) - ;; now get the actual message - (let ((myres (db:string->obj (receive-message* sub-socket)))) - (if (equal? query-sig (vector-ref myres 1)) - (set! res (vector-ref myres 2)) - (loop)))))) - (timeout (lambda () - (let loop ((n numretries)) - (thread-sleep! 15) - (if (not res) - (if (> numretries 0) - (begin - (debug:print 2 "WARNING: no reply to query " params ", trying resend") - (debug:print-info 11 "re-sending message") - (send-message push-socket zdat) - (debug:print-info 11 "message re-sent") - (loop (- n 1))) - ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) - (begin - (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") - (exit 5)))))))) - (debug:print-info 11 "Starting threads") - (let ((th1 (make-thread send-receive "send receive")) - (th2 (make-thread timeout "timeout"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1) - (debug:print-info 11 "cdb:client-call returning res=" res) - res)))))) - -(define (cdb:set-verbosity serverdat val) - (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) - -(define (cdb:login serverdat keyval signature) - (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) - -(define (cdb:logout serverdat keyval signature) - (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) - -(define (cdb:num-clients serverdat) - (cdb:client-call serverdat 'numclients #t *default-numtries*)) - -(define (cdb:test-set-status-state serverdat test-id status state msg) - (if msg - (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id) - (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) - -(define (cdb:test-rollup-test_data-pass-fail serverdat test-id) - (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) - -(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) - (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) - -(define (cdb:tests-register-test serverdat run-id test-name item-path) - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))) - -(define (cdb:flush-queue serverdat) - (cdb:client-call serverdat 'flush #f *default-numtries*)) - -(define (cdb:kill-server serverdat) - (cdb:client-call serverdat 'killserver #t *default-numtries*)) - -(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) - (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) - -(define (cdb:get-test-info serverdat run-id test-name item-path) - (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) - -(define (cdb:get-test-info-by-id serverdat test-id) - (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)) - -;; db should be db open proc or #f -(define (cdb:remote-run proc db . params) - (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) - -(define (db:test-get-logfile-info db run-id test-name) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (path final_logf) - (set! logf final_logf) - (set! res (list path final_logf)) - (if (directory? path) - (debug:print 2 "Found path: " path) - (debug:print 2 "No such path: " path))) - db - "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name) - res)) + ;; ((fs) msg) + ((http fs) + (if (string? msg) + (with-input-from-string + (z3:decode-buffer + (base64:base64-decode + (string-substitute + (regexp "_") "=" msg #t))) + (lambda ()(deserialize))) + (begin + (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.") + #f))) ;; crude reply for when things go awry + ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) + (else msg))) + +(define (db:test-set-status-state dbstruct run-id test-id status state msg) + (let ((dbdat (db:get-db dbstruct run-id))) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call dbdat 'set-test-start-time (list test-id))) + (if msg + (db:general-call dbdat 'state-status-msg (list state status msg test-id)) + (db:general-call dbdat 'state-status (list state status test-id))))) + +(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) + (if (and (not (equal? item-path "")) + (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED"))) + (let ((dbdat (db:get-db dbstruct run-id))) + (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) + (if (equal? status "RUNNING") + (db:general-call dbdat 'top-test-set-running (list test-name)) + (if (equal? status "LAUNCHED") + (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)) + (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) + #f) + #f)) + +(define (db:tests-register-test dbstruct run-id test-name item-path) + (db:with-db + dbstruct + run-id + #t + (lambda (db) + (sqlite3:execute db 'register-test run-id test-name item-path)))) + +(define (db:test-get-logfile-info dbstruct run-id test-name) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (path final_logf) + ;; (let ((path (sdb:qry 'getstr path-id)) + ;; (final_logf (sdb:qry 'getstr final_logf-id))) + (set! logf final_logf) + (set! res (list path final_logf)) + (if (directory? path) + (debug:print 2 "Found path: " path) + (debug:print 2 "No such path: " path))) ;; ) + db + "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" + test-name) + res)))) + +;;====================================================================== +;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S +;;====================================================================== (define db:queries - (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") - '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") - '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") - '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") + (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") + + ;; TESTS + '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") + ;; Test state and status + '(set-test-state "UPDATE tests SET state=? WHERE id=?;") + '(set-test-status "UPDATE tests SET state=? WHERE id=?;") + '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE + '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE + ;; Test comment + '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") + '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE + '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status - END WHERE id=?;") - '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") - '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") - '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") - '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") + END WHERE id=?;") ;; DONE + '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE + ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE + ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE + '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;") + '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE + "UPDATE tests SET state='DELETED' WHERE state=?") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") - )) + '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE + '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE + '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") + '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") + ;; stuff for roll-up-pass-fail-counts + '(update-pass-fail-counts "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) + WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set-per-pf-counts "UPDATE tests + SET state=CASE + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND status NOT IN ('TEN_STRIKES','BLOCKED') + AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' + ELSE 'COMPLETED' END, + status=CASE + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL' + WHEN fail_count > 0 THEN 'FAIL' + WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND status = 'SKIP') > 0 THEN 'SKIP' + ELSE 'UNKNOWN' END + WHERE testname=? AND item_path='';") ;; DONE + + ;; STEPS + '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") + '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field + )) + +(define (db:lookup-query qry-name) + (let ((q (alist-ref qry-name db:queries))) + (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail - db:roll-up-pass-fail-counts - login - immediate + ;; db:roll-up-pass-fail-counts ;; WHY NOT!? + login + immediate flush sync set-verbosity killserver )) -;; not used, intended to indicate to run in calling process -(define db:run-local-queries '()) ;; rollup-tests-pass-fail)) - -(define (db:process-cached-writes db) - (let ((queries (make-hash-table)) - (data #f)) - (mutex-lock! *incoming-mutex*) - ;; data is a list of query packets (length data) 0) - ;; Process if we have data - (begin - (debug:print-info 7 "Writing cached data " data) - - ;; Prepare the needed sql statements - ;; - (for-each (lambda (request-item) - (let ((stmt-key (vector-ref request-item 0)) - (query (vector-ref request-item 1))) - (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) - data) - - ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue - ;; and then are executed. - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (hed) - (let* ((params (vector-ref hed 2)) - (stmt-key (vector-ref hed 0)) - (stmt (hash-table-ref/default queries stmt-key #f))) - (if stmt - (apply sqlite3:execute stmt params) - (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) - data))) - - ;; let all the waiting calls know all is done - (mutex-lock! *completed-mutex*) - (for-each (lambda (item) - (let ((qry-sig (cdb:packet-get-client-sig item))) - (debug:print-info 7 "Registering query " qry-sig " as done") - (hash-table-set! *completed-writes* qry-sig #t))) - data) - (mutex-unlock! *completed-mutex*) - - ;; Finalize the statements. Should this be done inside the mutex above? - ;; I think sqlite3 mutexes will keep the data safe - (for-each (lambda (stmt-key) - (sqlite3:finalize! (hash-table-ref queries stmt-key))) - (hash-table-keys queries)) - - ;; Do a little record keeping - (let ((cache-size (length data))) - (if (> cache-size *max-cache-size*) - (set! *max-cache-size* cache-size))) - #t) - #f))) - -(define *db:process-queue-mutex* (make-mutex)) - -(define *number-of-writes* 0) -(define *writes-total-delay* 0) -(define *total-non-write-delay* 0) -(define *number-non-write-queries* 0) - -;; The queue is a list of vectors where the zeroth slot indicates the type of query to -;; apply and the second slot is the time of the query and the third entry is a list of -;; values to be applied -;; -(define (db:queue-write-and-wait db qry-sig query params) - (let ((queue-len 0) - (res #f) - (got-it #f) - (qry-pkt (vector qry-sig query params)) - (start-time (current-milliseconds)) - (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future - - ;; Put the item in the queue *incoming-writes* - (mutex-lock! *incoming-mutex*) - (set! *incoming-writes* (cons qry-pkt *incoming-writes*)) - (set! queue-len (length *incoming-writes*)) - (mutex-unlock! *incoming-mutex*) - - (debug:print-info 7 "Current write queue length is " queue-len) - - ;; poll for the write to complete, timeout after 10 seconds - ;; periodic flushing of the queue is taken care of by - ;; db:flush-queue - (let loop () - (thread-sleep! 0.001) - (mutex-lock! *completed-mutex*) - (if (hash-table-ref/default *completed-writes* qry-sig #f) - (begin - (hash-table-delete! *completed-writes* qry-sig) - (set! got-it #t))) - (mutex-unlock! *completed-mutex*) - (if (and (not got-it) - (< (current-seconds) timeout)) - (begin - (thread-sleep! 0.01) - (loop)))) - (set! *number-of-writes* (+ *number-of-writes* 1)) - (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) - got-it)) - -(define (db:process-queue-item db item) - (let* ((stmt-key (cdb:packet-get-qtype item)) - (qry-sig (cdb:packet-get-query-sig item)) - (return-address (cdb:packet-get-client-sig item)) - (params (cdb:packet-get-params item)) - (query (let ((q (alist-ref stmt-key db:queries))) - (if q (car q) #f)))) - (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params) - (if query - ;; hand queries off to the write queue - (let ((response (case *transport-type* - ((http) - (debug:print-info 7 "Queuing item " item " for wrapped write") - (db:queue-write-and-wait db qry-sig query params)) - (else - (apply sqlite3:execute db query params) - #t)))) - (debug:print-info 7 "Received " response " from wrapped write") - (server:reply return-address qry-sig response response)) - ;; otherwise if appropriate flush the queue (this is a read or complex query) - (begin - (cond - ((member stmt-key db:special-queries) - (let ((starttime (current-milliseconds))) - (debug:print-info 9 "Handling special statement " stmt-key) - (case stmt-key - ((immediate) - ;; This is a read or mixed read-write query, must clear the cache - (case *transport-type* - ((http) - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*))) - (let* ((proc (car params)) - (remparams (cdr params)) - ;; we are being handed a procedure so call it - ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") - (result (server:reply return-address qry-sig #t (apply proc remparams)))) - (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) - (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) - result)) - ((login) - (if (< (length params) 3) ;; should get toppath, version and signature - (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params - (let ((calling-path (car params)) - (calling-vers (cadr params)) - (client-key (caddr params))) - (if (and (equal? calling-path *toppath*) - (equal? megatest-version calling-vers)) - (begin - (hash-table-set! *logged-in-clients* client-key (current-seconds)) - (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... - (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) - ((flush sync) - (server:reply return-address qry-sig #t 1)) ;; (length data))) - ((set-verbosity) - (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) - ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (car *runremote*) - pullport: (cadr *runremote*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply return-address qry-sig #t '(#t "exit process started"))) - (else ;; not a command, i.e. is a query - (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) - (server:reply return-address qry-sig #f 'failed))))) - (else - (debug:print-info 11 "Executing " stmt-key " for " params) - (apply sqlite3:execute (hash-table-ref queries stmt-key) params) - (server:reply return-address qry-sig #t #t))))))) - -(define (db:test-get-records-for-index-file db run-id test-name) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) - (set! res (cons (vector id itempath state status run_duration logf comment) res))) - db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" - run-id test-name) - res)) - -;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count -;; NOTE: Is this duplicating (db:test-data-rollup db test-id status) ???? -(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) - ;; (cdb:flush-queue *runremote*) - (if (and (not (equal? item-path "")) - (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (begin - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name) - ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP? - (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING - (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) - (sqlite3:execute - db - "UPDATE tests - SET state=CASE - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 'RUNNING' - ELSE 'COMPLETED' END, - status=CASE - WHEN fail_count > 0 THEN 'FAIL' - WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND status = 'SKIP') > 0 THEN 'SKIP' - ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name)) - #f) - #f)) +(define (db:login dbstruct calling-path calling-version run-id client-signature) + (cond + ((not (equal? calling-path *toppath*)) + (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) + ((not (equal? *run-id* run-id)) + (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) + ((not (equal? megatest-version calling-version)) + (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) + (else + (hash-table-set! *logged-in-clients* client-signature (current-seconds)) + '(#t "successful login")))) + +(define (db:general-call dbdat stmtname params) + (let ((query (let ((q (alist-ref (if (string? stmtname) + (string->symbol stmtname) + stmtname) + db:queries))) + (if q (car q) #f)))) + (db:delay-if-busy dbdat) + (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) + #t)) ;; BUG or Sillyness, why do I return #t instead of the query result? + +;; get the previous records for when these tests were run where all keys match but runname +;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests +;; can use wildcards. Also can likely be factored in with get test paths? +;; +;; Run this remotely!! +;; +(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (keys (db:get-keys db)) + (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) + (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (keyvals #f) + (tests-hash (make-hash-table))) + ;; first look up the key values from the run selected by run-id + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (a . b) + (set! keyvals (cons a b))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (if (not keyvals) + '() + (let ((prev-run-ids '())) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + ;; collect all matching tests for the runs then + ;; extract the most recent test and return that. + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) '() ;; no previous runs? return null + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name + ", item-path " item-path " results: " (intersperse results "\n")) + ;; Keep only the youngest of any test/item combination + (for-each + (lambda (testdat) + (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) + (stored-test (hash-table-ref/default tests-hash full-testname #f))) + (if (or (not stored-test) + (and stored-test + (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) + ;; this test is younger, store it in the hash + (hash-table-set! tests-hash full-testname testdat)))) + results) + (if (null? tal) + (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests + (loop (car tal)(cdr tal)))))))))) + +(define (db:delay-if-busy dbdat #!key (count 6)) + (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (and dbdat (db:dbdat-get-db dbdat)) + (if dbdat + (let* ((dbpath (db:dbdat-get-path dbdat)) + (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline + (dbfj (conc dbpath "-journal"))) + (if (handle-exceptions + exn + (begin + (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) + (thread-sleep! 1) + (db:delay-if-busy count (- count 1))) + (file-exists? dbfj)) + (case count + ((6) + (thread-sleep! 0.2) + (db:delay-if-busy count: 5)) + ((5) + (thread-sleep! 0.4) + (db:delay-if-busy count: 4)) + ((4) + (thread-sleep! 0.8) + (db:delay-if-busy count: 3)) + ((3) + (thread-sleep! 1.6) + (db:delay-if-busy count: 2)) + ((2) + (thread-sleep! 3.2) + (db:delay-if-busy count: 1)) + ((1) + (thread-sleep! 6.4) + (db:delay-if-busy count: 0)) + (else + (debug:print-info 0 "delaying db access due to high database load.") + (thread-sleep! 12.8)))) + db) + "bogus result from db:delay-if-busy"))) + +(define (db:test-get-records-for-index-file dbstruct run-id test-name) + (let ((res '())) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id itempath state status run_duration logf comment) + (set! res (cons (vector id itempath state status run_duration logf comment) res))) + db + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" + test-name) + res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname -(define (db:testmeta-get-record db testname) +(define (db:testmeta-get-record dbstruct testname) (let ((res #f)) - (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" - testname) - res)) + (db:with-db + dbstruct + #f + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" + testname) + res)))) ;; create a new record for a given testname -(define (db:testmeta-add-record db testname) - (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) +(define (db:testmeta-add-record dbstruct testname) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:execute + db + "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields -(define (db:testmeta-update-field db testname field value) - (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) - -;;====================================================================== -;; T E S T D A T A -;;====================================================================== - -(define (db:csv->test-data db test-id csvdata) - (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((tdb (db:open-test-db-by-test-id db test-id))) - (if tdb - (let ((csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) - (for-each - (lambda (csvrow) - (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) - (category (list-ref padded-row 0)) - (variable (list-ref padded-row 1)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (if (>= value expected) "pass" "fail")) - ((<=) (if (<= value expected) "pass" "fail")) - (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type) - (sqlite3:finalize! tdb))) - csvlist))))) - -;; get a list of test_data records matching categorypatt -(define (db:read-test-data db test-id categorypatt) - (let ((tdb (db:open-test-db-by-test-id db test-id))) - (if tdb - (let ((res '())) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - tdb - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (sqlite3:finalize! tdb) - (reverse res)) - '()))) - -;; NOTE: Run this local with #f for db !!! -(define (db:load-test-data db test-id) - (let loop ((lin (read-line))) - (if (not (eof-object? lin)) - (begin - (debug:print 4 lin) - (db:csv->test-data db test-id lin) - (loop (read-line))))) - ;; roll up the current results. - ;; FIXME: Add the status to - (db:test-data-rollup db test-id #f)) - -;; WARNING: Do NOT call this for the parent test on an iterated test -;; Roll up test_data pass/fail results -;; look at the test_data status field, -;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. -;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored -(define (db:test-data-rollup db test-id status) - (let ((tdb (db:open-test-db-by-test-id db test-id)) - (fail-count 0) - (pass-count 0)) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (fcount pcount) - (set! fail-count fcount) - (set! pass-count pcount)) - tdb - "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, - (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" - test-id test-id) - (sqlite3:finalize! tdb) - - ;; Now rollup the counts to the central megatest.db - (cdb:pass-fail-counts *runremote* test-id fail-count pass-count) - ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" - ;; fail-count pass-count test-id) - - ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines - ;; next time you read this! - ;; - ;; (cdb:flush-queue *runremote*) - ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set - - ;; if the test is not FAIL then set status based on the fail and pass counts. - (cdb:test-rollup-test_data-pass-fail *runremote* test-id) - ;; (sqlite3:execute - ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME - ;; "UPDATE tests - ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 - ;; THEN 'FAIL' - ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND - ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - ;; THEN 'PASS' - ;; ELSE status - ;; END WHERE id=?;" - ;; test-id test-id test-id test-id) - )))) - -(define (db:get-prev-tol-for-test db test-id category variable) - ;; Finish me? - (values #f #f #f)) - -;;====================================================================== -;; S T E P S -;;====================================================================== - -(define (db:step-get-time-as-string vec) - (seconds->time-string (db:step-get-event_time vec))) - -;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id) - (let* ((tdb (db:open-test-db-by-test-id db test-id)) - (res '())) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res)) - '()))) - -;; get a pretty table to summarize steps -;; -(define (db:get-steps-table db test-id) - (let ((steps (db:get-steps-for-test db test-id))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (db:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (db:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)) - (case (string->symbol (db:step-get-state step)) - ((start)(vector-set! record 1 (db:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (db:step-get-status step))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (db:step-get-event_time step))) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (db:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - (else - (vector-set! record 2 (db:step-get-state step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (db:step-get-event_time step)))) - (hash-table-set! res (db:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)))) - ;; (else (vector-set! record 1 (db:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) - ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) - (< (db:step-get-id a) (db:step-get-id b))) - (else #f))))) - res))) - -;; get a pretty table to summarize steps -;; -(define (db:get-steps-table-list db test-id) - (let ((steps (db:get-steps-for-test db test-id))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (db:step-get-stepname step) - ;; stepname start end status - (vector (db:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)) - (case (string->symbol (db:step-get-state step)) - ((start)(vector-set! record 1 (db:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (db:step-get-status step))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (db:step-get-event_time step))) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (db:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (db:step-get-logfile step)) - 0) - (vector-set! record 5 (db:step-get-logfile step)))) - (else - (vector-set! record 2 (db:step-get-state step)) - (vector-set! record 3 (db:step-get-status step)) - (vector-set! record 4 (db:step-get-event_time step)))) - (hash-table-set! res (db:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (db:step-get-id step) - "\nstepname: " (db:step-get-stepname step) - "\nstate: " (db:step-get-state step) - "\nstatus: " (db:step-get-status step) - "\ntime: " (db:step-get-event_time step)))) - ;; (else (vector-set! record 1 (db:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) - ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) - (< (db:step-get-id a) (db:step-get-id b))) - (else #f))))) - res))) - -(define (db:get-compressed-steps test-id) - (let* ((comprsteps (open-run-close db:get-steps-table #f test-id))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (string (length mapparts) 1) (cadr mapparts) ""))) + (if replacement + (equal? (string-substitute pattern replacement patha) + (string-substitute pattern replacement pathb)) + (equal? (string-substitute pattern "" patha) + (string-substitute pattern "" pathb)))) + (equal? patha pathb))) ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; -;; Note: do not convert to remote as it calls remote under the hood ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only -;; mode 'itemmatch means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] +;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; -(define (db:get-prereqs-not-met db run-id waitons ref-item-path #!key (mode 'normal)) +;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) +(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (db:get-tests-for-run db run-id waitontest-name '() '())) + ;; next should be using mt:get-tests-for-run? + (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -1934,59 +2691,62 @@ ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... (let* ((state (db:test-get-state test)) (status (db:test-get-status test)) (item-path (db:test-get-item-path test)) (is-completed (equal? state "COMPLETED")) + (is-running (equal? state "RUNNING")) + (is-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - (same-itempath (equal? ref-item-path item-path))) + (same-itempath (db:compare-itempaths ref-item-path item-path itemmap))) ;; (equal? ref-item-path item-path))) (set! ever-seen #t) (cond ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test - is-completed - (or is-ok (eq? mode 'toplevel))) - (set! parent-waiton-met #t)) - ((and same-itempath - is-completed - (or is-ok (eq? mode 'toplevel))) - (set! item-waiton-met #t))))) - tests) + ((and (equal? item-path "") ;; this is the parent test of the waiton being examined + is-completed + (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and (equal? item-path "") ;; this is the parent test + is-killed + (member 'toplevel mode)) + (set! parent-waiton-met #t)) + ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met + ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) + ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items + same-itempath) + (if (and is-completed is-ok) + (set! item-waiton-met #t)) + (if (and (equal? item-path "") + (or is-completed is-running));; this is the parent, set it to run if completed or running + (set! parent-waiton-met #t))) + ;; normal checking of parent items, any parent or parent item not ok blocks running + ((and is-completed + (or is-ok + (member 'toplevel mode)) ;; toplevel does not block on FAIL + (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok + (set! item-waiton-met #t))))) + tests) + ;; both requirements, parent and item-waiton must be met to NOT add item to + ;; prereq's not met list (if (not (or parent-waiton-met item-waiton-met)) (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) -(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile) - (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) - ;; db:open-test-db-by-test-id does cdb:remote-run - (let* ((tdb (db:open-test-db-by-test-id db test-id)) - (state (items:check-valid-items "state" state-in)) - (status (items:check-valid-items "status" status-in))) - (if (or (not state)(not status)) - (debug:print 3 "WARNING: Invalid " (if status "status" "state") - " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if tdb - (begin - (sqlite3:execute - tdb - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" - test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile "")) - (sqlite3:finalize! tdb) - #t) - #f))) - ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== + +;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) -(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod) +(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (windows (and pathmod (substring-index "\\" pathmod))) @@ -2100,5 +2860,28 @@ results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") + +;; This is a list of all procs that write to the db +;; +;; (define *db:all-write-procs* +;; (list +;; db:set-var +;; db:del-var +;; db:register-run +;; db:set-comment-for-run +;; db:delete-run +;; db:update-run-event_time +;; db:lock/unlock-run +;; db:delete-test-step-records +;; db:delete-test-records +;; db:delete-tests-for-run +;; db:delete-old-deleted-test-records +;; db:set-tests-state-status +;; db:test-set-state-status-by-id +;; db:test-set-state-status-by-run-id-testname +;; db:testmeta-add-record +;; db:csv->test-data +;; )) + Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,6 +1,74 @@ -(define (make-db:test)(make-vector 6)) +;;====================================================================== +;; dbstruct +;;====================================================================== + +;; +;; -path-|-megatest.db +;; |-db-|-main.db +;; |-monitor.db +;; |-sdb.db +;; |-fdb.db +;; |-1.db +;; |-.db +;; +;; +;; Accessors for a dbstruct +;; + +(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) +(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) +(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) +(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) +(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) +(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) +(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) +(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) +(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) +;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) +;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) + +(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) +(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) +(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) +(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) +(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) +(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) +(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) +(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) +(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) +(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) +(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) +(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) +(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) +(define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) +(define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) + +; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) + +;; constructor for dbstruct +;; +(define (make-dbr:dbstruct #!key (path #f)(local #f)) + (let ((v (make-vector 15 #f))) + (dbr:dbstruct-set-path! v path) + (dbr:dbstruct-set-local! v local) + (dbr:dbstruct-set-locdbs! v (make-hash-table)) + v)) + +(define (dbr:dbstruct-get-localdb v run-id) + (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) + +(define (dbr:dbstruct-set-localdb! v run-id db) + (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) + + +(define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) @@ -7,15 +75,19 @@ (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) (define-inline (db:test-get-host vec) (vector-ref vec 6)) (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) (define-inline (db:test-get-uname vec) (vector-ref vec 9)) +;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) +(define-inline (db:test-get-process_id vec) (vector-ref vec 16)) +;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) +;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) (define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) @@ -26,13 +98,17 @@ (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) (define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) (define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) -;; get rows and header from -(define-inline (db:get-header vec)(vector-ref vec 0)) -(define-inline (db:get-rows vec)(vector-ref vec 1)) +;; 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 ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) @@ -97,41 +173,38 @@ ;; 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 7)) -(define-inline (db:step-get-id vec) (vector-ref vec 0)) -(define-inline (db:step-get-test_id vec) (vector-ref vec 1)) -(define-inline (db:step-get-stepname vec) (vector-ref vec 2)) -(define-inline (db:step-get-state vec) (vector-ref vec 3)) -(define-inline (db:step-get-status vec) (vector-ref vec 4)) -(define-inline (db:step-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:step-get-logfile vec) (vector-ref vec 6)) -(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val)) -(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val)) -(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val)) -(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val)) -(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val)) -(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val)) -(define-inline (db:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define-inline (tdb:step-get-id vec) (vector-ref vec 0)) +(define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) +(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) +(define-inline (tdb:step-get-state vec) (vector-ref vec 3)) +(define-inline (tdb:step-get-status vec) (vector-ref vec 4)) +(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) +(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) +(define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) +(define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) +(define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) -(define-inline (db:steps-table-get-stepname vec) (vector-ref vec 0)) -(define-inline (db:steps-table-get-start vec) (vector-ref vec 1)) -(define-inline (db:steps-table-get-end vec) (vector-ref vec 2)) -(define-inline (db:steps-table-get-status vec) (vector-ref vec 3)) -(define-inline (db:steps-table-get-runtime vec) (vector-ref vec 4)) -(define-inline (db:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) -(define-inline (db:step-stable-set-start! vec val)(vector-set! vec 1 val)) -(define-inline (db:step-stable-set-end! vec val)(vector-set! vec 2 val)) -(define-inline (db:step-stable-set-status! vec val)(vector-set! vec 3 val)) -(define-inline (db:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) - -;; use this one for db-get-run-info -(define-inline (db:get-row vec)(vector-ref vec 1)) +(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) +(define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) +(define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) +(define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) +(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) +(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) +(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) +(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) +(define-inline (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-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0)) (define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1)) ADDED dbwars/NOTES Index: dbwars/NOTES ================================================================== --- /dev/null +++ dbwars/NOTES @@ -0,0 +1,31 @@ +Before using prepare: + +matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert +Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far) +Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far) +Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far) +create-tests ran register-test 144000 times in 41.0 seconds + +After using prepare: + +matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert +Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far) +Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far) +Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far) +create-tests ran register-test 144000 times in 38.0 seconds + +After moving the prepare outside the call (so it isn't done each time): + +matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert +Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far) +Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far) +Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far) +create-tests ran register-test 144000 times in 33.0 seconds + +Using sql-de-lite with very similar code: + +matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert +Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far) +Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far) +create-tests ran register-test 144000 times in 31.0 seconds + ADDED dbwars/sql-de-lite-test.scm Index: dbwars/sql-de-lite-test.scm ================================================================== --- /dev/null +++ dbwars/sql-de-lite-test.scm @@ -0,0 +1,19 @@ + +(use sql-de-lite) +(include "test-common.scm") + +(define db (open-database "test.db")) + +(exec (sql db test-table-defn)) +(exec (sql db syncsetup)) + +(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) + (exec + stmth ;; (sql db test-insert) + run-id + testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) + +(let ((stmth (sql db test-insert))) + (create-tests stmth)) + +(close-database db) ADDED dbwars/sqlite3-test.scm Index: dbwars/sqlite3-test.scm ================================================================== --- /dev/null +++ dbwars/sqlite3-test.scm @@ -0,0 +1,20 @@ + +(use sqlite3) +(include "test-common.scm") + +(define db (open-database "test.db")) + +(execute db test-table-defn) +(execute db syncsetup) + + +(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) + (execute stmth + run-id + testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) + +(let ((stmth (prepare db test-insert))) + (create-tests stmth) + (finalize! stmth)) + +(finalize! db) ADDED dbwars/test-common.scm Index: dbwars/test-common.scm ================================================================== --- /dev/null +++ dbwars/test-common.scm @@ -0,0 +1,129 @@ +(use srfi-18 srfi-69 apropos) + +(define args (argv)) + +(if (not (eq? (length args) 2)) + (begin + (print "Usage: sqlitecompare [insert|update]") + (exit 0))) + +(define action (string->symbol (cadr args))) + +(system "rm -f test.db") + +(define test-table-defn + "CREATE TABLE IF NOT EXISTS tests + (id INTEGER PRIMARY KEY, + run_id INTEGER, + testname TEXT, + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT 'n/a', + shortdir TEXT DEFAULT '', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'FAIL', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat BLOB, + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time TIMESTAMP, + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) + );") + +(define test-insert "INSERT INTO tests (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time) + values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );") +(define syncsetup "PRAGMA synchronous = OFF;") + +(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9")) +(define items '()) +(for-each + (lambda (n) + (for-each + (lambda (m) + (set! items (cons (conc "item/" n m) items))) + '(0 1 2 3 4 5 6 7 8 9))) + '(0 1 2 3 4 5 6 7 8 9)) +(define hosts '("host0" "host1" "host2")) ;; "host3" "host4" "host5" "host6" "host7" "host8" "host9")) +(define cpuloads '(0.1 0.2 0.3)) ;; 0.4 0.5 0.6 0.7 0.8 0.9)) +(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000)) +(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux") +(define basedir "/mfs/matt/data/megatest/runs/testing") +(define final-logf "finallog.html") +(define run-durations (list 120 240)) ;; 260)) +(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?")) + +(define run-ids (make-hash-table)) +(define max-run-id 1000) + +(define (test-factors->run-id host cpuload diskfree run-duration comment) + (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment)) + (run-id (hash-table-ref/default run-ids factor #f))) + (if run-id + (list run-id factor) + (let ((new-id (+ max-run-id 1))) + (set! max-run-id new-id) + (hash-table-set! run-ids factor new-id) + (list new-id factor))))) + + +(define (create-tests stmth) + (let ((num-created 0) + (last-print (current-seconds)) + (start-time (current-seconds))) + (for-each + (lambda (test) + (for-each + (lambda (item) + (for-each + (lambda (host) + (for-each + (lambda (cpuload) + (for-each + (lambda (diskfree) + (for-each + (lambda (run-duration) + (for-each + (lambda (comment) + (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment)) + (run-id (car run-id-dat)) + (factor (cadr run-id-dat)) + (curr-time (current-seconds))) + (if (> (- curr-time last-print) 10) + (begin + (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)") + (set! last-print curr-time))) + (set! num-created (+ num-created 1)) + (register-test stmth ;; db + run-id + test ;; testname + host + cpuload + diskfree + uname + (conc basedir "/" test "/" item) ;; rundir + (conc test "/" item) ;; shortdir + item ;; item-path + "NOT_STARTED" ;; state + "NA" ;; status + final-logf + run-duration + comment + (current-seconds)))) + comments)) + run-durations)) + diskfrees)) + cpuloads)) + hosts)) + items)) + tests) + (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds"))) + + + ADDED dcommon.scm Index: dcommon.scm ================================================================== --- /dev/null +++ dcommon.scm @@ -0,0 +1,772 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) +(use regex) + +(declare (unit dcommon)) + +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses db)) +(declare (uses synchash)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") + +;; yes, this is non-ideal +(define dashboard:update-summary-tab #f) +(define dashboard:update-servers-table #f) + +;;====================================================================== +;; C O M M O N D A T A S T R U C T U R E +;;====================================================================== +;; +;; A single data structure for all the data used in a dashboard. +;; Share this structure between newdashboard and dashboard with the +;; intent of converging on a single app. +;; +(define *data* (make-vector 25 #f)) +(define (dboard:data-get-runs vec) (vector-ref vec 0)) +(define (dboard:data-get-tests vec) (vector-ref vec 1)) +(define (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) +(define (dboard:data-get-tests-tree vec) (vector-ref vec 3)) +(define (dboard:data-get-run-keys vec) (vector-ref vec 4)) +(define (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) +;; (define (dboard:data-get-test-details vec) (vector-ref vec 6)) +(define (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) +(define (dboard:data-get-updaters vec) (vector-ref vec 8)) +(define (dboard:data-get-path-run-ids vec) (vector-ref vec 9)) +(define (dboard:data-get-curr-run-id vec) (vector-ref vec 10)) +(define (dboard:data-get-runs-tree vec) (vector-ref vec 11)) +;; For test-patts convert #f to "" +(define (dboard:data-get-test-patts vec) + (let ((val (vector-ref vec 12)))(if val val ""))) +(define (dboard:data-get-states vec) (vector-ref vec 13)) +(define (dboard:data-get-statuses vec) (vector-ref vec 14)) +(define (dboard:data-get-logs-textbox vec val)(vector-ref vec 15)) +(define (dboard:data-get-command vec) (vector-ref vec 16)) +(define (dboard:data-get-command-tb vec) (vector-ref vec 17)) +(define (dboard:data-get-target vec) (vector-ref vec 18)) +(define (dboard:data-get-target-string vec) + (let ((targ (dboard:data-get-target vec))) + (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) +(define (dboard:data-get-run-name vec) (vector-ref vec 19)) +(define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) + +(define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) +(define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) +(define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) +(define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) +(define (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) +(define (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) +;; (define (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) +(define (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) +(define (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) +(define (dboard:data-set-path-run-ids! vec val)(vector-set! vec 9 val)) +(define (dboard:data-set-curr-run-id! vec val)(vector-set! vec 10 val)) +(define (dboard:data-set-runs-tree! vec val)(vector-set! vec 11 val)) +;; For test-patts convert "" to #f +(define (dboard:data-set-test-patts! vec val) + (vector-set! vec 12 (if (equal? val "") #f val))) +(define (dboard:data-set-states! vec val)(vector-set! vec 13 val)) +(define (dboard:data-set-statuses! vec val)(vector-set! vec 14 val)) +(define (dboard:data-set-logs-textbox! vec val)(vector-set! vec 15 val)) +(define (dboard:data-set-command! vec val)(vector-set! vec 16 val)) +(define (dboard:data-set-command-tb! vec val)(vector-set! vec 17 val)) +(define (dboard:data-set-target! vec val)(vector-set! vec 18 val)) +(define (dboard:data-set-run-name! vec val)(vector-set! vec 19 val)) +(define (dboard:data-set-runs-listbox! vec val)(vector-set! vec 20 val)) + +(dboard:data-set-run-keys! *data* (make-hash-table)) + +;; List of test ids being viewed in various panels +(dboard:data-set-curr-test-ids! *data* (make-hash-table)) + +;; Look up test-ids by (key1 key2 ... testname [itempath]) +(dboard:data-set-path-test-ids! *data* (make-hash-table)) + +;; Look up run-ids by ?? +(dboard:data-set-path-run-ids! *data* (make-hash-table)) + +;;====================================================================== +;; TARGET AND PATTERN MANIPULATIONS +;;====================================================================== + +;; Convert to and from list of lines (for a text box) +;; "," => "\n" +(define (dboard:test-patt->lines test-patt) + (string-substitute (regexp ",") "\n" test-patt)) + +(define (dboard:lines->test-patt lines) + (string-substitute (regexp "\n") "," lines #t)) + + +;;====================================================================== +;; P R O C E S S R U N S +;;====================================================================== + +;; MOVE THIS INTO *data* +(define *cachedata* (make-hash-table)) +(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) +(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) + +;; TO-DO +;; 1. Make "data" hash-table hierarchial store of all displayed data +;; 2. Update synchash to understand "get-runs", "get-tests" etc. +;; 3. Add extraction of filters to synchash calls +;; +;; Mode is 'full or 'incremental for full refresh or incremental refresh +(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) + (let* (;; count and offset => #f so not used + ;; the synchash calls modify the "data" hash + (get-runs-sig (conc (client:get-signature) " get-runs")) + (get-tests-sig (conc (client:get-signature) " get-tests")) + (get-details-sig (conc (client:get-signature) " get-test-details")) + + ;; test-ids to get and display are indexed on window-id in curr-test-ids hash + (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) + + (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) + (tests-detail-changes (if (not (null? test-ids)) + (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) + '())) + + ;; Now can calculate the run-ids + (run-hash (hash-table-ref/default data get-runs-sig #f)) + (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) + + (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f)) + (runs-hash (hash-table-ref/default data get-runs-sig #f)) + (header (hash-table-ref/default runs-hash "header" #f)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a header "event_time")) + (time-b (db:get-value-by-header record-b header "event_time"))) + (> time-a time-b))) + )) + (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) + (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) + (colnum 1) + (rownum 0)) ;; rownum = 0 is the header +;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) + + ;; tests related stuff + ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) + + ;; Given a run-id and testname/item_path calculate a cell R:C + + ;; NOTE: Also build the test tree browser and look up table + ;; + ;; Each run is unique on its keys and runname or run-id, store in hash on colnum + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) + keys)) + (run-name (db:get-value-by-header run-record header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) col-name) + (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (set! colnum (+ colnum 1)))) + run-ids) + + ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table + ;; Do this analysis in the order of the run-ids, the most recent run wins + (for-each (lambda (run-id) + (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) + (new-test-dat (car test-changes)) + (removed-tests (cadr test-changes)) + (tests (sort (map cadr (filter (lambda (testrec) + (eq? run-id (db:mintest-get-run_id (cadr testrec)))) + new-test-dat)) + (lambda (a b) + (let ((time-a (db:mintest-get-event_time a)) + (time-b (db:mintest-get-event_time b))) + (> time-a time-b))))) + ;; test-changes is a list of (( id record ) ... ) + ;; Get list of test names sorted by time, remove tests + (test-names (delete-duplicates (map (lambda (t) + (let ((i (db:mintest-get-item_path t)) + (n (db:mintest-get-testname t))) + (if (string=? i "") + (conc " " i) + n))) + tests))) + (colnum (car (hash-table-ref runid-to-col run-id)))) + ;; for each test name get the slot if it exists and fill in the cell + ;; or take the next slot and fill in the cell, deal with items in the + ;; run view panel? The run view panel can have a tree selector for + ;; browsing the tests/items + + ;; SWITCH THIS TO USING CHANGED TESTS ONLY + (for-each (lambda (test) + (let* ((test-id (db:mintest-get-id test)) + (state (db:mintest-get-state test)) + (status (db:mintest-get-status test)) + (testname (db:mintest-get-testname test)) + (itempath (db:mintest-get-item_path test)) + (fullname (conc testname "/" itempath)) + (dispname (if (string=? itempath "") testname (conc " " itempath))) + (rownum (hash-table-ref/default testname-to-row fullname #f)) + (test-path (append run-path (if (equal? itempath "") + (list testname) + (list testname itempath)))) + (tb (dboard:data-get-tests-tree *data*))) + (print "INFONOTE: run-path: " run-path) + (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" + test-path + userdata: (conc "test-id: " test-id)) + (let ((node-num (tree:find-node tb (cons "Runs" test-path))) + (color (car (gutils:get-color-for-state-status state status)))) + (debug:print 0 "node-num: " node-num ", color: " color) + (iup:attribute-set! tb (conc "COLOR" node-num) color)) + (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) + (if (not rownum) + (let ((rownums (hash-table-values testname-to-row))) + (set! rownum (if (null? rownums) + 1 + (+ 1 (apply max rownums)))) + (hash-table-set! testname-to-row fullname rownum) + ;; create the label + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" 0) dispname) + )) + ;; set the cell text and color + ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) + (if (string=? state "COMPLETED") + status + state)) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc "BGCOLOR" rownum ":" colnum) + (car (gutils:get-color-for-state-status state status))) + )) + tests))) + run-ids) + + (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) + (if updater (updater (hash-table-ref/default data get-details-sig #f)))) + + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") + ;; (debug:print 2 "run-changes: " run-changes) + ;; (debug:print 2 "test-changes: " test-changes) + (list run-changes test-changes))) + +;;====================================================================== +;; TESTS DATA +;;====================================================================== + +;; Produce a list of lists ready for common:sparse-list-generate-index +;; +(define (dcommon:minimize-test-data tests-dat) + (if (null? tests-dat) + '() + (let loop ((hed (car tests-dat)) + (tal (cdr tests-dat)) + (res '())) + (let* ((test-id (vector-ref hed 0)) ;; look at the tests-dat spec for locations + (test-name (vector-ref hed 1)) + (item-path (vector-ref hed 2)) + (state (vector-ref hed 3)) + (status (vector-ref hed 4)) + (newitem (list test-name item-path (list test-id state status)))) + (if (null? tal) + (reverse (cons newitem res)) + (loop (car tal)(cdr tal)(cons newitem res))))))) + + +;;====================================================================== +;; D A T A T A B L E S +;;====================================================================== + +;; Table of keys +(define (dcommon:keys-matrix rawconfig) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") + (iup:attribute-set! keys-matrix "WIDTH0" 0) + (iup:attribute-set! keys-matrix "0:1" "Key Name") + ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) + (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + key-vals) + (iup:attribute-set! keys-matrix "WIDTHDEF" "40") + keys-matrix)) + +;; Section to table +(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig sectionname)) + (section-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:scrollbar "YES"))) + (iup:attribute-set! section-matrix "0:0" varcolname) + (iup:attribute-set! section-matrix "0:1" valcolname) + (iup:attribute-set! section-matrix "WIDTH1" "200") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) + (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + key-vals) + (iup:vbox + (iup:label (if title title (conc "Settings from [" sectionname "]")) + ;; #:size "5x" + #:expand "HORIZONTAL" + ) + section-matrix))) + +;; General data +;; +(define (dcommon:general-info) + (let ((general-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2))) + (iup:attribute-set! general-matrix "WIDTH1" "150") + (iup:attribute-set! general-matrix "0:1" "About this Megatest area") + ;; User (this is not always obvious - it is common to run as a different user + (iup:attribute-set! general-matrix "1:0" "User") + (iup:attribute-set! general-matrix "1:1" (current-user-name)) + ;; Megatest area + ;; (iup:attribute-set! general-matrix "2:0" "Area") + ;; (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; Megatest version + (iup:attribute-set! general-matrix "2:0" "Version") + (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + + general-matrix)) + +(define (dcommon:run-stats dbstruct) + (let* ((stats-matrix (iup:matrix expand: "YES")) + (changed #f) + (updater (lambda () + (let* ((run-stats (db:get-run-stats dbstruct)) + (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) + (row-indices (car indices)) + (col-indices (cadr indices)) + (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 + (apply max (map cadr col-indices)))) + (max-visible (max (- *num-tests* 15) 3)) + (max-col-vis (if (> max-col 10) 10 max-col)) + (numrows 1) + (numcols 1)) + (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! stats-matrix "NUMCOL" max-col ) + (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) + (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + row-indices) + + ;; Col labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + col-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (car entry)) + (col-name (cadr entry)) + (value (caddr entry)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (if (not (equal? (iup:attribute stats-matrix key) value)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key value))))) + run-stats) + (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))) + (updater) + (set! dashboard:update-summary-tab updater) + (iup:attribute-set! stats-matrix "WIDTHDEF" "40") + (iup:vbox + ;; (iup:label "Run statistics" #:expand "HORIZONTAL") + stats-matrix))) + +(define (dcommon:servers-table) + (let* ((tdbdat (tasks:open-db)) + (colnum 0) + (rownum 0) + (servers-matrix (iup:matrix #:expand "YES" + #:numcol 7 + #:numcol-visible 7 + #:numlin-visible 5 + )) + (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) + (updater (lambda () + (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) + ;; (set! colnum 0) + ;; (for-each (lambda (colname) + ;; ;; (print "colnum: " colnum " colname: " colname) + ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + ;; (set! colnum (+ 1 colnum))) + ;; colnames) + (set! rownum 1) + (for-each + (lambda (server) + (set! colnum 0) + (let* ((vals (list (vector-ref server 0) ;; Id + (vector-ref server 9) ;; MT-Ver + (vector-ref server 1) ;; Pid + (vector-ref server 2) ;; Hostname + (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) + ;; (vector-ref server 5) ;; Pubport + ;; (vector-ref server 10) ;; Last beat + ;; (vector-ref server 6) ;; Start time + ;; (vector-ref server 7) ;; Priority + ;; (vector-ref server 8) ;; State + (vector-ref server 8) ;; State + (vector-ref server 12) ;; RunId + ))) + (for-each (lambda (val) + (let* ((row-col (conc rownum ":" colnum)) + (curr-val (iup:attribute servers-matrix row-col))) + (if (not (equal? (conc val) curr-val)) + (begin + (iup:attribute-set! servers-matrix row-col val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) + (set! colnum (+ 1 colnum)))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL")) + servers))))) + (set! colnum 0) + (for-each (lambda (colname) + (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ colnum 1))) + colnames) + (set! dashboard:update-servers-table updater) + ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") + ;; (iup:hbox + ;; (iup:vbox + ;; (iup:button "Start" + ;; ;; #:size "50x" + ;; #:expand "YES" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Stop" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0 &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Restart" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0;megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))) + ;; servers-matrix + ;; ))) + servers-matrix + )) + +;; The main menu +(define (dcommon:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +;;====================================================================== +;; CANVAS STUFF FOR TESTS +;;====================================================================== + +(define (dcommon:draw-test cnv x y w h name selected) + (let* ((llx x) + (lly y) + (urx (+ x w)) + (ury (+ y h))) + (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) + (canvas-rectangle! cnv llx urx lly ury) + (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) + +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (boxw 90) ;; default, overriden by length estimate below + (boxh 25) + (gapx 20) + (gapy 30) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (hash-table-set! tests-draw-state 'xtorig xtorig) + (hash-table-set! tests-draw-state 'ytorig ytorig) + (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) + (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) + (if (> x-max boxw)(set! boxw (+ 10 x-max))))) + ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames))) + (llx xtorig) + (lly ytorig) + (urx (+ xtorig boxw)) + (ury (+ ytorig boxh))) + ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) + (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + ;; data used by mouse click calc. keep the wacky order for now. + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (let ((have-room + (if #t ;; put "auto" here where some form of auto rearanging can be done + (> (* 3 (+ boxw gapx)) (- urx xtorig)) + (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? + (loop (car tal) + (cdr tal) + (if have-room (+ llx boxw gapx) xtorig) ;; have room, + (if have-room lly (+ lly boxh gapy)) + (if have-room (+ urx boxw gapx) (+ xtorig boxw)) + (if have-room ury (+ ury boxh gapy))))))))) + +(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) + (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (hash-table-set! tests-draw-state 'xtorig xtorig) + (hash-table-set! tests-draw-state 'ytorig ytorig) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames)))) + (let* ((tvals (hash-table-ref tests-hash hed)) + (llx (+ xdelta (list-ref tvals 0))) + (lly (+ ydelta (list-ref tvals 4))) + (boxw (list-ref tvals 5)) + (boxh (list-ref tvals 6)) + (urx (+ llx boxw)) + (ury (+ lly boxh))) + (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (loop (car tal) + (cdr tal)))))))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! +;; +;; get a pretty table to summarize steps +;; +(define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (tdb:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +(define (dcommon:get-compressed-steps dbstruct run-id test-id) + (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) + (comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string rownum max-row)(set! max-row rownum)) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 6) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) + (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (if (> max-row 0) + (begin + ;; we are going to speculatively clear rows until we find a row that is already cleared + (let loop ((rownum (+ max-row 1)) + (colnum 0) + (deleted #f)) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) + (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) ADDED docs/dashboard-summary-tab.png Index: docs/dashboard-summary-tab.png ================================================================== --- /dev/null +++ docs/dashboard-summary-tab.png cannot compute difference between binary files Index: docs/html/megatest.html ================================================================== --- docs/html/megatest.html +++ docs/html/megatest.html @@ -2,11 +2,11 @@ - + Megatest User Manual
@@ -782,11 +782,11 @@
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try.
-figure monitor-state-diagram.png +figure monitor-state-diagram.png

14 Reference

@@ -1708,10 +1708,10 @@ B References
Index: docs/html/monitor-state-diagram.png ================================================================== --- docs/html/monitor-state-diagram.png +++ docs/html/monitor-state-diagram.png cannot compute difference between binary files Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,5 +1,14 @@ +all : server.pdf megatest_manual.html client.pdf -megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt +megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt asciidoc megatest_manual.txt dos2unix megatest_manual.html +server.pdf : server.dot + dot -Tpdf server.dot > server.pdf + +client.pdf : client.dot + dot -Tpdf client.dot > client.pdf + +clean: + rm -f megatest_manual.html ADDED docs/manual/client.dot Index: docs/manual/client.dot ================================================================== --- /dev/null +++ docs/manual/client.dot @@ -0,0 +1,35 @@ +digraph G { + + // put client after server so server_start node is visible + // + subgraph cluster_2 { + node [style=filled,shape=box]; + + "client:setup start" -> runremote_lookup_server; + runremote_lookup_server -> login_attempt [label="have server"]; + runremote_lookup_server -> monitordb_lookup_server [label="no server"]; + + monitordb_lookup_server -> login_attempt [label="have server"]; + monitordb_lookup_server -> server_start_remote [label="no server"]; + + server_start_remote -> delay_2_sec; + delay_2_sec -> runremote_lookup_server; + + login_attempt -> "rmt:send-receive_start" [label="login sucessful"]; + "rmt:send-receive_start" -> "rmt:send-receive_start"; + + "rmt:send-receive_start" -> runremote_lookup_server [label=exception]; + login_attempt -> clear_runremote [label="login failed"]; + + "remove_running > 5s" -> runremote_lookup_server; + + subgraph cluster_3 { + node [style=filled]; + clear_runremote -> "remove_running > 5s"; + } + + label = "client:setup"; + color=green; + } + +} ADDED docs/manual/howto.txt Index: docs/manual/howto.txt ================================================================== --- /dev/null +++ docs/manual/howto.txt @@ -0,0 +1,69 @@ + +How To Do Things +================ + +Tricks +------ + +This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest. + +Limiting your running jobs +-------------------------- + +The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously. + +In your testconfig: + +---------------- +[test_meta] +jobgroup group1 +---------------- + +In your megatest.config: + +--------------- +[jobgroups] +group1 10 +custdes 4 +--------------- + + + + +Debugging Tricks +---------------- + +Examining The Environment +~~~~~~~~~~~~~~~~~~~~~~~~~ + +During Config File Processing +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Organising Your Tests and Tasks +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +---------------------------- +[tests-paths] +1 #{get misc parent}/simplerun/tests +---------------------------- + +------------------- +[setup] +------------------- + +The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS + +------------------- +runscript main.csh +------------------- + +Debugging Server Problems +~~~~~~~~~~~~~~~~~~~~~~~~~ + +---------------- +sudo lsof -i +sudo netstat -lptu +sudo netstat -tulpn +---------------- Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,1009 +1,1284 @@ - - - - - -The Megatest Users Manual - - - - - -
-
-

Dedication

-
-

Dedicated to my wife Joanna who has kindly supported my working on various projects over the years.

-
-

Thanks

-
-

Thank you the many people I’ve worked over the years who have -shared their knowledge and insights with me.

-

Thanks also to the creators of the various open source projects that -Megatest is built on. These include Linux, xemacs, chicken scheme, -fossil and asciidoc. Without these projects something like Megatest -would be difficult or impossible to do.

-
-
-
-
-
-

Preface

-
-

This book is organised as three sub-books; getting started, writing tests and reference.

-
-

Why Megatest?

-

The Megatest project was started for two reasons, the first was an -immediate and pressing need for a generalized tool to manage a suite -of regression tests and the second was the fact that I had written or -maintained several such tools at different companies over the years -and it seemed a good thing to have a single open source tool, flexible -enough to meet the needs of any team doing continuous integrating and -or running a complex suite of tests for release qualification.

-
-
-

Megatest Design Philosophy

-

Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and implementing continuous build for -software, design engineering or process control (via owlfs for -example) without being specialized for any specific problem -space. Megatest in of itself does not know what constitutes a PASS or -FAIL of a test. In most cases megatest is best used in conjunction -with logpro or a similar tool to parse, analyze and decide on the test -outcome.

-
-
-

Megatest Architecture

-

All data to specify the tests and configure the system is stored in -plain text files. All system state is stored in an sqlite3 -database. Tests are launched using the launching system available for -the distributed compute platform in use. A template script is provided -which can launch jobs on local and remote Linux hosts. Currently -megatest uses the network filesystem to call home to your master -sqlite3 database.

-
-
-
-

Getting Started

-
-
Getting started with Megatest
-
-

How to install Megatest and set it up for running your regressions and continuous integration process.

-
-
-

Installation

-
-
-

Dependencies

-

Chicken scheme and a number of "eggs" are required for building -Megatest. See the script installall.sch in the utils directory of the -distribution for a mostly automated way to install everything needed -for building Megatest on Linux.

-


[An example footnote.]

-

And now for something completely different: monkeys, lions and -tigers (Bengal and Siberian) using the alternative syntax index -entries. - - - -Note that multi-entry terms generate separate index entries.

-

Here are a couple of image examples: an -images/smallnew.png - -example inline image followed by an example block image:

-
-
-Tiger image -
-
Figure 1. Tiger block image
-
-

Followed by an example table:

-
- - --- - - - - - - - - - - - - - - - -
Table 1. An example table
Option Description

-a USER GROUP

Add USER to GROUP.

-R GROUP

Disables access to GROUP.

-
-
-
Example 1. An example example
-
-

Lorum ipum…

-
-
-
-

Sub-section with Anchor

-

Sub-section at level 2.

-
-

Chapter Sub-section

-

Sub-section at level 3.

-
-
Chapter Sub-section
-

Sub-section at level 4.

-

This is the maximum sub-section depth supported by the distributed -AsciiDoc configuration. -
[A second example footnote.]

-
-
-
-
-
-
-

The Second Chapter

-
-

An example link to anchor at start of the first sub-section.

-

An example link to a bibliography entry [taoup].

-
-
-

Reference

-
-

The First Chapter of the Second Part

-
-

Chapters grouped into book parts are at level 1 and can contain -sub-sections.

-
-
-
-

The testconfig File

-
-
-
-
# testconfig
-[requirements]
-
-# A normal waiton waits for the prior tests to be COMPLETED
-# and PASS, CHECK or WAIVED
-waiton test1 test2
-
-# A item based waiton will start items in a test when the
-# same-named item is COMPLETED and PASS, CHECK or WAIVED
-# in the prior test
-#
-mode   normal | toplevel
-
-# With a toplevel test you may wish to generate your list
-# of tests to run dynamically
-#
-# waiton #{shell get-valid-tests-to-run.sh}
-
-
-
-
-

Appendix A: Example Appendix

-
-

One or more optional appendixes go here at section level zero.

-
-

Appendix Sub-section

-
- - - -
-
Note
-		Preface and appendix subsections start out of sequence at level -2 (level 1 is skipped). This only applies to multi-part book -documents.
-
-
-
-
-
-

Example Bibliography

-
-

The bibliography list is a style of AsciiDoc bulleted list.

-
    -
  • -

    -[taoup] Eric Steven Raymond. The Art of Unix - Programming. Addison-Wesley. ISBN 0-13-142901-9. -

    -
    • -
  • -

    -[walsh-muellner] Norman Walsh & Leonard Muellner. - DocBook - The Definitive Guide. O’Reilly & Associates. 1999. - ISBN 1-56592-580-7. -

    -
    • -
-
-
-
-

Example Glossary

-
-

Glossaries are optional. Glossaries entries are an example of a style -of AsciiDoc labeled lists.

-
-
-A glossary term -
-
-

- The corresponding (indented) definition. -

-
-
-A second glossary term -
-
-

- The corresponding (indented) definition. -

-
-
-
-
-
-

Example Colophon

-
-

Text at the end of a book describing facts about its production.

-
-
-
-

Example Index

-
-
-
-
-
- - - + + + + + +The Megatest Users Manual + + + + + +
+
+

Preface

+
+

This book is organised as three sub-books; getting started, writing tests and reference.

+
+

Why Megatest?

+

The Megatest project was started for two reasons, the first was an +immediate and pressing need for a generalized tool to manage a suite +of regression tests and the second was the fact that the author had +written or maintained several such tools at different companies over +the years and it seemed a good thing to have a single open source +tool, flexible enough to meet the needs of any team doing continuous +integrating and or running a complex suite of tests for release +qualification.

+
+
+

Megatest Design Philosophy

+

Megatest is intended to provide the minimum needed resources to make +writing a suite of tests and tasks for implementing continuous build +for software, design engineering or process control (via owlfs for +example) without being specialized for any specific problem +space. Megatest in of itself does not know what constitutes a PASS or +FAIL of a test. In most cases megatest is best used in conjunction +with logpro or a similar tool to parse, analyze and decide on the test +outcome.

+
+
+

Megatest Architecture

+

All data to specify the tests and configure the system is stored in +plain text files. All system state is stored in an sqlite3 +database. Tests are launched using the launching system available for +the distributed compute platform in use. A template script is provided +which can launch jobs on local and remote Linux hosts. Currently +megatest uses the network filesystem to call home to your master +sqlite3 database.

+
+
+
+

Road Map

+

Note 1: This road-map is tentative and subject to change without notice.

+

Note 2: Starting over. Old plan is commented out.

+
+

Current Items

+
+
+

ww05 - migrate to inmem-db

+

Keep as much the same as possible. Add internal reference to almost +eliminate contention on db(s).

+
    +
  1. +

    +Add internal reference db +

    +
    2. +
  2. +

    +Verify that actions are accessing correct db +

    +
      +
    1. +

      +-runtests - inmem +

      +
      2. +
    2. +

      +-list-runs - local (but not megatest.db) +

      +
      3. +
    3. +

      +dashboard - local (but not megatest.db) +

      +
      4. +
    +
    3. +
  3. +

    +Mirror db to /var/tmp… +

    +
    4. +
  4. +

    +Dashboard read db from per-run db. +

    +
    5. +
  5. +

    +Dashboard read db from /var/tmp +

    +
    6. +
  6. +

    +Runs register in tasks table in monitor.db +

    +
    7. +
  7. +

    +Server polls tasks table for next action (in addition?) +

    +
    8. +
  8. +

    +Change run loop to execute in server, triggered by call to polling of tasks table +

    +
    9. +
+
+
+
+

Getting Started

+
+
Getting started with Megatest
+
+

How to install Megatest and set it up for running your regressions and continuous integration process.

+
+
+

Installation

+
+
+

Dependencies

+

Chicken scheme and a number of "eggs" are required for building +Megatest. See the script installall.sch in the utils directory of the +distribution for a mostly automated way to install everything needed +for building Megatest on Linux.

+


[An example footnote.]

+

And now for something completely different: monkeys, lions and +tigers (Bengal and Siberian) using the alternative syntax index +entries. + + + +Note that multi-entry terms generate separate index entries.

+

Here are a couple of image examples: an +images/smallnew.png + +example inline image followed by an example block image:

+
+
+Tiger image +
+
Figure 1. Tiger block image
+
+

Followed by an example table:

+
+ + +++ + + + + + + + + + + + + + + + +
Table 1. An example table
Option Description

-a USER GROUP

Add USER to GROUP.

-R GROUP

Disables access to GROUP.

+
+
+
Example 1. An example example
+
+

Lorum ipum…

+
+
+
+

Sub-section with Anchor

+

Sub-section at level 2.

+
+

Chapter Sub-section

+

Sub-section at level 3.

+
+
Chapter Sub-section
+

Sub-section at level 4.

+

This is the maximum sub-section depth supported by the distributed +AsciiDoc configuration. +
[A second example footnote.]

+
+
+
+
+
+
+

The Second Chapter

+
+

An example link to anchor at start of the first sub-section.

+

An example link to a bibliography entry [taoup].

+
+
+

Writing Tests

+
+

The First Chapter of the Second Part

+
+

Chapters grouped into book parts are at level 1 and can contain +sub-sections.

+
+
+

How To Do Things

+
+

Tricks

+
+

This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest.

+
+
+
+

Limiting your running jobs

+
+

The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.

+

In your testconfig:

+
+
+
[test_meta]
+jobgroup group1
+
+

In your megatest.config:

+
+
+
[jobgroups]
+group1 10
+custdes 4
+
+
+
+
+

Debugging Tricks

+
+
+

Examining The Environment

+
+

During Config File Processing

+
+
+

Organising Your Tests and Tasks

+
+
+
[tests-paths]
+1 #{get misc parent}/simplerun/tests
+
+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
+

Debugging Server Problems

+
+
+
sudo lsof -i
+sudo netstat -lptu
+sudo netstat -tulpn
+
+
+
+
+

Reference

+
+

The First Chapter of the Second Part

+
+

Chapters grouped into book parts are at level 1 and can contain +sub-sections.

+
+
+
+

The testconfig File

+
+
+

Setup section

+
+

Header

+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
+

Requirements section

+
+

Header

+
+
+
[requirements]
+
+
+
+

Wait on Other Tests

+
+
+
# A normal waiton waits for the prior tests to be COMPLETED
+# and PASS, CHECK or WAIVED
+waiton test1 test2
+
+
+
+

Mode

+

The default (i.e. if mode is not specified) is normal. All pre-dependent tests +must be COMPLETED and PASS, CHECK or WAIVED before the test will start

+
+
+
mode   normal
+
+

The toplevel mode requires only that the prior tests are COMPLETED.

+
+
+
mode toplevel
+
+

A item based waiton will start items in a test when the +same-named item is COMPLETED and PASS, CHECK or WAIVED +in the prior test

+
+
+
mode itemmatch
+
+
+
+
# With a toplevel test you may wish to generate your list
+# of tests to run dynamically
+#
+# waiton #{shell get-valid-tests-to-run.sh}
+
+
+
+

Run time limit

+
+
+
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+
+
+
+

Skip

+
+
+

Header

+
+
+
[skip]
+
+
+
+

Skip on Still-running Tests

+
+
+
# NB// If the prevrunning line exists with *any* value the test will
+# automatically SKIP if the same-named test is currently RUNNING
+
+prevrunning x
+
+
+
+

Skip if a File Exists

+
+
+
fileexists /path/to/a/file # skip if /path/to/a/file exists
+
+
+
+

Controlled waiver propagation

+

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: +If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

+

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

+
+
+
###### EXAMPLE FROM testconfig #########
+# matching file(s) will be diff'd with previous run and logpro applied
+# if PASS or WARN result from logpro then WAIVER state is set
+#
+[waivers]
+# logpro_file    rulename      input_glob
+waiver_1         logpro        lookittmp.log
+
+[waiver_rules]
+
+# This builtin rule is the default if there is no <waivername>.logpro file
+# diff   diff %file1% %file2%
+
+# This builtin rule is applied if a <waivername>.logpro file exists
+# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
+
+
+
+
+

Ezsteps

+

To transfer the environment to the next step you can do the following:

+
+
+
$MT_MEGATEST -env2file .ezsteps/${stepname}
+
+
+
+

Triggers

+

In your testconfig triggers can be specified

+
+
+
[triggers]
+
+# Call script running.sh when test goes to state=RUNNING, status=PASS
+RUNNING/PASS running.sh
+
+# Call script running.sh any time state goes to RUNNING
+RUNNING/ running.sh
+
+# Call script onpass.sh any time status goes to PASS
+PASS/ onpass.sh
+
+

Scripts called will have; test-id test-rundir trigger, added to the commandline.

+

HINT

+

To start an xterm (useful for debugging), use a command line like the following:

+
+
+
[triggers]
+COMPLETED/ xterm -e bash -s --
+
+
+ + + +
+
Note
+		There is a trailing space after the --
+
+
+
+

Megatest Internals

+
+
+server.png +
+
+
+
+
+
+

Appendix A: Example Appendix

+
+

One or more optional appendixes go here at section level zero.

+
+

Appendix Sub-section

+
+ + + +
+
Note
+		Preface and appendix subsections start out of sequence at level +2 (level 1 is skipped). This only applies to multi-part book +documents.
+
+
+
+
+
+

Example Bibliography

+
+

The bibliography list is a style of AsciiDoc bulleted list.

+
    +
  • +

    +[taoup] Eric Steven Raymond. The Art of Unix + Programming. Addison-Wesley. ISBN 0-13-142901-9. +

    +
    • +
  • +

    +[walsh-muellner] Norman Walsh & Leonard Muellner. + DocBook - The Definitive Guide. O’Reilly & Associates. 1999. + ISBN 1-56592-580-7. +

    +
    • +
+
+
+
+

Example Glossary

+
+

Glossaries are optional. Glossaries entries are an example of a style +of AsciiDoc labeled lists.

+
+
+A glossary term +
+
+

+ The corresponding (indented) definition. +

+
+
+A second glossary term +
+
+

+ The corresponding (indented) definition. +

+
+
+
+
+
+

Example Colophon

+
+

Text at the end of a book describing facts about its production.

+
+
+
+

Example Index

+
+
+
+
+
+ + + Index: docs/manual/megatest_manual.txt ================================================================== --- docs/manual/megatest_manual.txt +++ docs/manual/megatest_manual.txt @@ -3,27 +3,10 @@ Matt Welland v1.0, April 2012 :doctype: book -[dedication] -Dedication -========== - -Dedicated to my wife Joanna who has kindly supported my working on various projects over the years. - -Thanks ------- - -Thank you the many people I've worked over the years who have -shared their knowledge and insights with me. - -Thanks also to the creators of the various open source projects that -Megatest is built on. These include Linux, xemacs, chicken scheme, -fossil and asciidoc. Without these projects something like Megatest -would be difficult or impossible to do. - [preface] Preface ======= This book is organised as three sub-books; getting started, writing tests and reference. @@ -30,22 +13,23 @@ Why Megatest? ~~~~~~~~~~~~~ The Megatest project was started for two reasons, the first was an immediate and pressing need for a generalized tool to manage a suite -of regression tests and the second was the fact that I had written or -maintained several such tools at different companies over the years -and it seemed a good thing to have a single open source tool, flexible -enough to meet the needs of any team doing continuous integrating and -or running a complex suite of tests for release qualification. +of regression tests and the second was the fact that the author had +written or maintained several such tools at different companies over +the years and it seemed a good thing to have a single open source +tool, flexible enough to meet the needs of any team doing continuous +integrating and or running a complex suite of tests for release +qualification. Megatest Design Philosophy ~~~~~~~~~~~~~~~~~~~~~~~~~~ Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and implementing continuous build for -software, design engineering or process control (via owlfs for +writing a suite of tests and tasks for implementing continuous build +for software, design engineering or process control (via owlfs for example) without being specialized for any specific problem space. Megatest in of itself does not know what constitutes a PASS or FAIL of a test. In most cases megatest is best used in conjunction with logpro or a similar tool to parse, analyze and decide on the test outcome. @@ -59,39 +43,23 @@ the distributed compute platform in use. A template script is provided which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database. -include::getting_started.txt[] include::writing_tests.txt[] +include::../plan.txt[] +include::getting_started.txt[] +include::writing_tests.txt[] +include::howto.txt[] include::reference.txt[] - -Controlled waiver propagation -============================= -If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: -If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED - -Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined) - -========================================================= -###### EXAMPLE FROM testconfig ######### -# matching file(s) will be diff'd with previous run and logpro applied -# if PASS or WARN result from logpro then WAIVER state is set -# -[waivers] -# logpro_file rulename input_glob -waiver_1 logpro lookittmp.log - -[waiver_rules] - -# This builtin rule is the default if there is no .logpro file -# diff diff %file1% %file2% - -# This builtin rule is applied if a .logpro file exists -# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html -========================================================= - +Megatest Internals +~~~~~~~~~~~~~~~~~~ + +["graphviz", "server.png"] +---------------------------------------------------------------------- +include::server.dot[] +---------------------------------------------------------------------- [appendix] Example Appendix ================ Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -2,33 +2,184 @@ Reference ========= The First Chapter of the Second Part ------------------------------------ + Chapters grouped into book parts are at level 1 and can contain sub-sections. The testconfig File ------------------- +Setup section +~~~~~~~~~~~~~ + +Header +^^^^^^ + +------------------- +[setup] +------------------- + +The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS + +------------------- +runscript main.csh ------------------- -# testconfig + +Requirements section +~~~~~~~~~~~~~~~~~~~~ + +Header +^^^^^^ + +------------------- [requirements] +------------------- + +Wait on Other Tests +^^^^^^^^^^^^^^^^^^^ +------------------- # A normal waiton waits for the prior tests to be COMPLETED # and PASS, CHECK or WAIVED waiton test1 test2 +------------------- + +Mode +^^^^ + +The default (i.e. if mode is not specified) is normal. All pre-dependent tests +must be COMPLETED and PASS, CHECK or WAIVED before the test will start + +------------------- +mode normal +------------------- + +The toplevel mode requires only that the prior tests are COMPLETED. + +------------------- +mode toplevel +------------------- + +A item based waiton will start items in a test when the +same-named item is COMPLETED and PASS, CHECK or WAIVED +in the prior test + +------------------- +mode itemmatch +------------------- -# A item based waiton will start items in a test when the -# same-named item is COMPLETED and PASS, CHECK or WAIVED -# in the prior test -# -mode normal | toplevel +------------------- # With a toplevel test you may wish to generate your list # of tests to run dynamically # # waiton #{shell get-valid-tests-to-run.sh} ------------------ + + +Run time limit +^^^^^^^^^^^^^^ + +----------------- +runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s +----------------- + +Skip +^^^^ + +Header +^^^^^^ + +----------------- +[skip] +----------------- + +Skip on Still-running Tests +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +----------------- +# NB// If the prevrunning line exists with *any* value the test will +# automatically SKIP if the same-named test is currently RUNNING + +prevrunning x +----------------- + +Skip if a File Exists +^^^^^^^^^^^^^^^^^^^^^ + +----------------- +fileexists /path/to/a/file # skip if /path/to/a/file exists +----------------- + +Controlled waiver propagation +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: +If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED + +Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined) + +----------------- +###### EXAMPLE FROM testconfig ######### +# matching file(s) will be diff'd with previous run and logpro applied +# if PASS or WARN result from logpro then WAIVER state is set +# +[waivers] +# logpro_file rulename input_glob +waiver_1 logpro lookittmp.log + +[waiver_rules] + +# This builtin rule is the default if there is no .logpro file +# diff diff %file1% %file2% + +# This builtin rule is applied if a .logpro file exists +# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html +----------------- + +Ezsteps +~~~~~~~ + +To transfer the environment to the next step you can do the following: + +---------------------------- +$MT_MEGATEST -env2file .ezsteps/${stepname} +---------------------------- + +Triggers +~~~~~~~~ + +In your testconfig triggers can be specified + +----------------- +[triggers] + +# Call script running.sh when test goes to state=RUNNING, status=PASS +RUNNING/PASS running.sh + +# Call script running.sh any time state goes to RUNNING +RUNNING/ running.sh + +# Call script onpass.sh any time status goes to PASS +PASS/ onpass.sh +----------------- + +Scripts called will have; test-id test-rundir trigger, added to the commandline. + +HINT + +To start an xterm (useful for debugging), use a command line like the following: + +----------------- +[triggers] +COMPLETED/ xterm -e bash -s -- +----------------- + +NOTE: There is a trailing space after the -- + :numbered!: ADDED docs/manual/server.dot Index: docs/manual/server.dot ================================================================== --- /dev/null +++ docs/manual/server.dot @@ -0,0 +1,62 @@ +digraph G { + + subgraph cluster_1 { + node [style=filled,shape=box]; + + check_available_queue -> remove_entries_over_10s_old; + remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; + remove_entries_over_10s_old -> exit [label="num_avail > 2"]; + + set_available -> delay_2s; + delay_2s -> check_place_in_queue; + + check_place_in_queue -> "http:transport-launch" [label="at head"]; + check_place_in_queue -> exit [label="not at head"]; + + "client:login" -> "server:shutdown" [label="login failed"]; + "server:shutdown" -> exit; + + subgraph cluster_2 { + "http:transport-launch" -> "http:transport-run"; + "http:transport-launch" -> "http:transport-keep-running"; + + "http:transport-keep-running" -> "tests running?"; + "tests running?" -> "client:login" [label=yes]; + "tests running?" -> "server:shutdown" [label=no]; + "client:login" -> delay_5s [label="login ok"]; + delay_5s -> "http:transport-keep-running"; + } + + // start_server -> "server_running?"; + // "server_running?" -> set_available [label="no"]; + // "server_running?" -> delay_2s [label="yes"]; + // delay_2s -> "still_running?"; + // "still_running?" -> ping_server [label=yes]; + // "still_running?" -> set_available [label=no]; + // ping_server -> exit [label=alive]; + // ping_server -> remove_server_record [label=dead]; + // remove_server_record -> set_available; + // set_available -> avail_delay [label="delay 3s"]; + // avail_delay -> "first_in_queue?"; + // + // "first_in_queue?" -> set_running [label=yes]; + // set_running -> get_next_port -> handle_requests; + // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; + // "dead_entry_in_queue?" -> "server_running?" [label=no]; + // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; + // remove_dead_entries -> "server_running?"; + // + // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; + // handle_requests -> shutdown_request; + // start_shutdown -> shutdown_delay; + // shutdown_request -> shutdown_delay; + // shutdown_delay -> exit; + + label = "server:launch"; + color=brown; + } + +// client_start_server -> start_server; +// handle_requests -> read_write; +// read_write -> handle_requests; +} ADDED docs/manual/server.pdf Index: docs/manual/server.pdf ================================================================== --- /dev/null +++ docs/manual/server.pdf cannot compute difference between binary files ADDED docs/manual/server.png Index: docs/manual/server.png ================================================================== --- /dev/null +++ docs/manual/server.png cannot compute difference between binary files ADDED docs/manual_running_of_tests.png Index: docs/manual_running_of_tests.png ================================================================== --- /dev/null +++ docs/manual_running_of_tests.png cannot compute difference between binary files ADDED docs/megatest-about.svg Index: docs/megatest-about.svg ================================================================== --- /dev/null +++ docs/megatest-about.svg @@ -0,0 +1,492 @@ + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + Megatest + Simple - but not TOO simple! + + Automation + Quality Assurance + Regression Testing + System Administration + + + + + + Write one task or test and iterateDistribute tasks over one or many hostsOrganize runs by any variables you wish - release - architecture - unit or partitionTasks or tests may depend on othersEach task or test runs in clean areaAdd disk space or partitions as neededRigorous results; error, pass, warn etc.Crontab friendly runs (skip if running)Easy debugging - easy to recreate environment for task - annotated HTML logs help find issuesSimplify scripts - eliminate for-each or while loops - parallel running handled by tool + + FAIL + + PASS + + WARN + + ADDED docs/megatest-state-status.dot Index: docs/megatest-state-status.dot ================================================================== --- /dev/null +++ docs/megatest-state-status.dot @@ -0,0 +1,47 @@ +digraph megatest_state_status { + ranksep=0.05 + // rankdir=LR + +node [shape=box,style=filled]; + +// subgraph cluster_notstarted { +// label="Not started"; + + "NOT_STARTED FAILS" [ + label = "{ NOT_STARTED/FAILS |{ NO_ITEMS | FAIL_PREREQ | FAIL_TIMEOUT }}"; + shape= "record"; + ] + +"NOT_STARTED n/a" -> "LAUNCHED n/a" [label=" launch"]; +"NOT_STARTED WAIT" -> "LAUNCHED n/a" + + "NOT_STARTED n/a"; + "NOT_STARTED WAIT" [ + label = "{NOT_STARTED WAIT|{ NO_SLOTS | WAIT_PREREQ}}"; + shape = "record"; +] + +// struct3 [shape=record,label="hello\nworld |{ b |{c| d|e}| f}| g | h"]; + + "NOT_STARTED n/a" -> "NOT_STARTED FAILS"; + "NOT_STARTED n/a" -> "NOT_STARTED WAIT"; + + "RUNNING" [ + shape="record"; + label="{RUNNING|{n/a| PASS | FAIL}}"; + ] + + "COMPLETED" [ + shape="record"; + label = "{COMPLETED|{PASS | FAIL | CHECK| SKIP}}"; + ] + + +"RUNNING" -> "COMPLETED"; +"RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"]; + + +"LAUNCHED n/a" -> "REMOTEHOSTSTART n/a" -> "RUNNING"; + +} + Index: docs/megatest-training.odp ================================================================== --- docs/megatest-training.odp +++ docs/megatest-training.odp cannot compute difference between binary files Index: docs/megatest-training.pdf ================================================================== --- docs/megatest-training.pdf +++ docs/megatest-training.pdf cannot compute difference between binary files Index: docs/plan.txt ================================================================== --- docs/plan.txt +++ docs/plan.txt @@ -1,13 +1,107 @@ - -Move test specific db to test dir -================================= - -. Create teststats.db -. Redirect test run stats to teststats.db -. Redirect test steps data to teststats.db -. Redirect test_data to teststats.db -. Direct dboard to get stats from teststats.db -. Redirect kill requests to teststats.db -. Kill requests need to kill all processes in the tree -. Roll up overall stats to megatest.db every five minutes or when test done -. Add any necessary tests +Road Map +======== + +Note 1: This road-map is tentative and subject to change without notice. + +Note 2: Starting over. Old plan is commented out. + +Current Items +------------- + +ww05 - migrate to inmem-db +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Keep as much the same as possible. Add internal reference to almost +eliminate contention on db(s). + +. Add internal reference db +. Verify that actions are accessing correct db +.. -runtests - inmem +.. -list-runs - local (but not megatest.db) +.. dashboard - local (but not megatest.db) +. Mirror db to /var/tmp... +. Dashboard read db from per-run db. +. Dashboard read db from /var/tmp +. Runs register in tasks table in monitor.db +. Server polls tasks table for next action (in addition?) +. Change run loop to execute in server, triggered by call to polling of tasks table + + +// ww32 +// ~~~~ +// +// . Rerun step and or subsequent steps from gui +// . Refresh test area files from gui +// . Clean and re-run button +// . Clean up STATE and STATUS handling. +// .. Dashboard and Test control panel are reverse order - choose and fix +// .. Move seldom used states and status to drop down selector +// . Access test control panel when clicking on Run Summary tests +// . Feature: -generate-index-tree +// . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 +// +// ww33 +// ~~~~ +// +// . http api available for use with Perl, Ruby etc. scripts +// . megatest.config setup entries for: +// .. run launching (e.g. /bin/sh %CMD% > /dev/null) +// .. browser "konqueror %FNAME% +// +// ww34 +// ~~~~ +// +// . Mark dependent tests for clean/rerun -rerun-downstream +// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify +// . Fix: refresh of gui sometimes fails on last item (race condition?) +// +// ww35 +// ~~~~ +// +// . refdb: Add export of csv, json and sexp +// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. +// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. +// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test +// . Refactor Run Summary view, currently very clumsy +// . Add option to show steps in Run Summary view +// +// ww36 +// ~~~~ +// +// . Refactor guis for resizeablity +// . Add filters to Run Summary view and Run Control view +// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS... +// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G +// +// Bin List +// ~~~~~~~~ +// +// . Quality improvements +// .. Server stutters occasionally +// .. Large number of items or tests still has some issues. +// .. Code refactoring +// .. Replace remote process with true API using json (supports Web app also) +// . Streamline the gui +// .. Everything resizable +// .. Less clutter +// .. Tool tips +// .. Filters on Run Summary, Summary and Run Control panel +// .. Built in log viewer (partially implemented) +// .. Refactor the test control panel +// . Help and documentation +// .. Complete the user manual (I’ve been working on this lately). +// .. Online help in the gui +// . Streamlined install +// .. Deployed version (download a location independent ready to run binary bundle) +// .. Install Makefile (in progress, needed for Mike to install on VMs) +// .. Added option to compile IUP (needed for VMs) +// . Server side run launching +// . Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). +// . Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). +// . Wizards for creating tests, regression areas (current ones are text only and limited). +// . Fully functional built in web service (currently you can browse runs but it is very simplistic). +// . Wildcards in runconfigs: e.g. [p1271/9/%/%] +// . Gui panels for editing megatest.config and runconfigs.config +// . Fully isolated tests (no use of NFS to see regression area files) +// . Windows version + ADDED docs/results.pdf Index: docs/results.pdf ================================================================== --- /dev/null +++ docs/results.pdf cannot compute difference between binary files ADDED example/cfg/machines.dat Index: example/cfg/machines.dat ================================================================== --- /dev/null +++ example/cfg/machines.dat @@ -0,0 +1,16 @@ +[] +[maxload] +zeus 0.40000000000000002 +xena 0.20000000000000001 +myth2 0.01 +hades 1 +[minfree] +zeus 1000 +xena 20000 +myth2 300000 +hades 4000000 +[reqprocs] +zeus mfsmount mythbackend mfschunkserver +xena mfsmount +myth2 mfsmount mythfrontend mfschunkserver +hades mfsmount mfsmetalogger mfschunkserver ADDED example/cfg/sheet-names.cfg Index: example/cfg/sheet-names.cfg ================================================================== --- /dev/null +++ example/cfg/sheet-names.cfg @@ -0,0 +1,1 @@ +machines ADDED example/cfg/sxml/_sheets.sxml Index: example/cfg/sxml/_sheets.sxml ================================================================== --- /dev/null +++ example/cfg/sxml/_sheets.sxml @@ -0,0 +1,47 @@ +((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2014-02-14T06:16:26Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2014-02-14T06:16:17Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "machines")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "835") (Height "320"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))) ADDED example/cfg/sxml/_workbook.sxml Index: example/cfg/sxml/_workbook.sxml ================================================================== --- /dev/null +++ example/cfg/sxml/_workbook.sxml @@ -0,0 +1,1 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) ADDED example/cfg/sxml/machines.sxml Index: example/cfg/sxml/machines.sxml ================================================================== --- /dev/null +++ example/cfg/sxml/machines.sxml @@ -0,0 +1,105 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "4") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"machines\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "52.5") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "182.2") (No "3") (HardSize "1")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (Count "5")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "4") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "4") (startCol "0") (endRow "4") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) Index: example/megatest.config ================================================================== --- example/megatest.config +++ example/megatest.config @@ -1,8 +1,8 @@ [fields] -PLATFORM TEXT -OS TEXT +CFG_TYPE This is the refdb to use. +RUN_TYPE Can be: full or quick [setup] # Adjust max_concurrent_jobs to limit parallel jobs max_concurrent_jobs 50 @@ -9,16 +9,14 @@ # This is your link path, best to set it and then not change it linktree #{getenv PWD}/linktree # Job tools control how your jobs are launched [jobtools] -useshell yes -launcher nbfind - -# You can override environment variables for all your tests here -[env-override] -EXAMPLE_VAR example value +launcher nbfake # As you run more tests you may need to add additional disks # the names are arbitrary but must be unique [disks] disk0 #{getenv PWD}/runs + +[include local.megatest.config] + Index: example/runconfigs.config ================================================================== --- example/runconfigs.config +++ example/runconfigs.config @@ -1,6 +1,9 @@ [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] -[SYSTEM_val/RELEASE_val] +[cfg/default] ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val + +[include local.runconfigs.config] + DELETED example/tests/checkspace/checkspace.logpro Index: example/tests/checkspace/checkspace.logpro ================================================================== --- example/tests/checkspace/checkspace.logpro +++ /dev/null @@ -1,3 +0,0 @@ -(expect:error in "LogFileBody" = 0 "Any error" #/err/i) -(expect:required in "LogFileBody" = 1 "Sucess signature" #/adequate space/) - DELETED example/tests/checkspace/checkspace.sh Index: example/tests/checkspace/checkspace.sh ================================================================== --- example/tests/checkspace/checkspace.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -e -freespace=`df -k $DIRECTORY | grep $DIRECTORY | awk '{print $4}'` -if [[ $freespace -lt $REQUIRED ]];then - echo "ERROR: insufficient space on $DIRECTORY" - exit 1 -else - echo "There is adequate space on $DIRECTORY" -fi DELETED example/tests/checkspace/testconfig Index: example/tests/checkspace/testconfig ================================================================== --- example/tests/checkspace/testconfig +++ /dev/null @@ -1,9 +0,0 @@ -# Add steps here. Format is "stepname script" -[ezsteps] -checkspace checkspace.sh - -# Iteration for your tests are controlled by the items section -[itemstable] -DIRECTORY /tmp /opt -REQUIRED 1000000 100000 - ADDED example/tests/diskspace/diskspace.logpro Index: example/tests/diskspace/diskspace.logpro ================================================================== --- /dev/null +++ example/tests/diskspace/diskspace.logpro @@ -0,0 +1,6 @@ +;; Analyze the output from diskspace.sh +;; +(expect:error in "LogFileBody" = 0 "Insufficient space" #/ERROR: available space is less/) +(expect:error in "LogFileBody" = 0 "Any error" #/err/i) +(expect:required in "LogFileBody" > 1 "Sucess signature" #/INFO: space available/) + ADDED example/tests/diskspace/diskspace.sh Index: example/tests/diskspace/diskspace.sh ================================================================== --- /dev/null +++ example/tests/diskspace/diskspace.sh @@ -0,0 +1,24 @@ +#!/bin/bash -e + +filter=`refdb lookup $MT_RUN_AREA_HOME/$CFG_TYPE machines $TARGETHOST filter` + +echo "Using filter: $filter" + +diskareas=`mount | egrep 'ext|mfs|nfs'| egrep -v "$filter" | awk '{print $3}'` + +for dirname in $diskareas;do + + echo "dirname: $dirname" + + # measure the free space + freespace=`df -P -k $dirname | grep $dirname | awk '{print $4}'` + + # get the minfree allowed from the refdb + minfree=`refdb lookup $MT_RUN_AREA_HOME/$CFG_TYPE machines $TARGETHOST minfree` + + if [[ "$freespace" -lt "$minfree" ]];then + echo "ERROR: available space $freespace is less than minimum allowed of $minfree on $dirname" + else + echo "INFO: space available of $freespace k on $dirname meets required minimum of $minfree." + fi +done ADDED example/tests/diskspace/hostname.logpro Index: example/tests/diskspace/hostname.logpro ================================================================== --- /dev/null +++ example/tests/diskspace/hostname.logpro @@ -0,0 +1,4 @@ +(define hostname (get-host-name)) + +(expect:required in "LogFileBody" > 0 (conc "Hostname matches " hostname) (regexp (conc "^" hostname "$"))) + ADDED example/tests/diskspace/testconfig Index: example/tests/diskspace/testconfig ================================================================== --- /dev/null +++ example/tests/diskspace/testconfig @@ -0,0 +1,12 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +hostname hostname +diskspace diskspace.sh + +[requirements] +waiton ping +mode itemwait + +# Iteration for your tests are controlled by the items section +[items] +TARGETHOST [system refdb getrownames $CFG_TYPE machines] ADDED example/tests/ping/ping.logpro Index: example/tests/ping/ping.logpro ================================================================== --- /dev/null +++ example/tests/ping/ping.logpro @@ -0,0 +1,3 @@ +(expect:error in "LogFileBody" = 0 "Any error" #/err/i) +(expect:required in "LogFileBody" = 5 "Successful pings" #/bytes from.*/) + ADDED example/tests/ping/testconfig Index: example/tests/ping/testconfig ================================================================== --- /dev/null +++ example/tests/ping/testconfig @@ -0,0 +1,7 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +ping ping -c 5 $PINGHOST + +# Iteration for your tests are controlled by the items section +[items] +PINGHOST [system refdb getrownames $CFG_TYPE machines] Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -8,19 +8,168 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") -; (include "key_records.scm") -; (include "db_records.scm") -; (include "run_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") + +(define (ezsteps:run-from testdat start-step-name run-one) + (let* ((test-run-dir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) + (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) + (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) + (run-mutex (make-mutex)) + (rollup-status 0) + (exit-info (vector #t #t #t)) + (test-id (db:test-get-id testdat)) + (run-id (db:test-get-run_id testdat)) + (test-name (db:test-get-testname testdat)) + (kill-job #f)) ;; for future use (on re-factoring with launch.scm code + (let loop ((count 5)) + (if (file-exists? test-run-dir) + (push-directory test-run-dir) + (if (> count 0) + (begin + (debug:print 0 "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") + (sleep 3) + (loop (- count 1)))))) + (debug:print-info 0 "Running in directory " test-run-dir) + (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + (if (not (> (length ezstepslst) 0)) + (message-window "ERROR: You can only re-run steps defined via ezsteps") + (begin + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (prevstep #f) + (runflag #f)) ;; flag used to skip steps when not starting at the beginning + (if (vector-ref exit-info 1) + (let* ((stepname (car ezstep)) ;; do stuff to run the step + (stepinfo (cadr ezstep)) + (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) + (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each + (stepcmd (list-ref stepparts 3)) + (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!! + (logpro-used #f)) + + ;; Skip steps until hit start-step-name + ;; + (if (and start-step-name + (not runflag)) + (if (equal? stepname start-step-name) + (set! runflag #t) ;; and continue + (if (not (null? tal)) + (loop (car tal)(cdr tal) stepname #f)))) + (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + " stepparms: " stepparms " stepcmd: " stepcmd) + + (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) + + ;; call the command using mt_ezstep + (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) + + (debug:print 4 "script: " script) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + ;; now launch + (let ((pid (process-run script))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! run-mutex) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! run-mutex) + (if (eq? pid-val 0) + (begin + (thread-sleep! 1) + (processloop (+ i 1)))) + )) + (let ((exinfo (vector-ref exit-info 2)) + (logfna (if logpro-used (conc stepname ".html") ""))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) + (if logpro-used + (rmt:test-set-log! test-id (conc stepname ".html"))) + ;; set the test final status + (let* ((this-step-status (cond + ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) + ((eq? (vector-ref exit-info 2) 0) 'pass) + (else 'fail))) + (overall-status (cond + ((eq? rollup-status 2) 'warn) + ((eq? rollup-status 0) 'pass) + (else 'fail))) + (next-status (cond + ((eq? overall-status 'pass) this-step-status) + ((eq? overall-status 'warn) + (if (eq? this-step-status 'fail) 'fail 'warn)) + (else 'fail)))) + (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + " this-step-status: " this-step-status " overall-status: " overall-status + " next-status: " next-status " rollup-status: " rollup-status) + (case next-status + ((warn) + (set! rollup-status 2) + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! test-id "RUNNING" "WARN" + (if (eq? this-step-status 'warn) "Logpro warning found" #f) + #f)) + ((pass) + (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) + (else ;; 'fail + (set! rollup-status 1) ;; force fail + (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + )))) + (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) + (not (null? tal))) + (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop + (loop (car tal) (cdr tal) stepname runflag)))) + (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) + + ;; Once done with step/steps update the test record + ;; + (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) + (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + ;; Am I completed? + (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + ;; "COMPLETED" + ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ) + (new-status (cond + ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run + ((eq? rollup-status 0) + ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + ((eq? rollup-status 1) "FAIL") + ((eq? rollup-status 2) + ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + (else "FAIL")))) ;; (db:test-get-status testinfo))) + (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) + (tests:test-set-status! test-id + new-state + new-status + (args:get-arg "-m") #f) + ;; need to update the top test record if PASS or FAIL and this is a subtest + (if (not (equal? item-path "")) + (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))) + ;; for automated creation of the rollup html file this is a good place... + (if (not (equal? item-path "")) + (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no + ))) + (pop-directory) + rollup-status)) ADDED fdb_records.scm Index: fdb_records.scm ================================================================== --- /dev/null +++ fdb_records.scm @@ -0,0 +1,19 @@ +;; Single record for managing a filedb +;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache +;; Filedb record +(define (make-filedb:fdb)(make-vector 5)) +(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0)) +(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1)) +(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2)) +(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3)) +(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4)) +(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val)) +(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val)) +(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val)) +(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val)) + +;; children records, should have use something other than "child" +(define-inline (filedb:child-get-id vec) (vector-ref vec 0)) +(define-inline (filedb:child-get-path vec) (vector-ref vec 1)) +(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2)) ADDED filedb.scm Index: filedb.scm ================================================================== --- /dev/null +++ filedb.scm @@ -0,0 +1,246 @@ +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) +(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit filedb)) + +(include "fdb_records.scm") +;; (include "settings.scm") + +(define (filedb:open-db dbpath) + (let* ((fdb (make-filedb:fdb)) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath))) + (filedb:fdb-set-db! fdb db) + (filedb:fdb-set-dbpath! fdb dbpath) + (filedb:fdb-set-pathcache! fdb (make-hash-table)) + (filedb:fdb-set-idcache! fdb (make-hash-table)) + (filedb:fdb-set-partcache! fdb (make-hash-table)) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + ;; NB// We store a useful subset of file attributes but do not attempt to store all + (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + path TEXT, + parent_id INTEGER, + mode INTEGER DEFAULT -1, + uid INTEGER DEFAULT -1, + gid INTEGER DEFAULT -1, + size INTEGER DEFAULT -1, + mtime INTEGER DEFAULT -1);") + (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") + (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + ;; close the sqlite3 db and open it as needed + (filedb:finalize-db! fdb) + (filedb:fdb-set-db! fdb #f) + fdb)) + +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + +(define (filedb:finalize-db! fdb) + (sqlite3:finalize! (filedb:fdb-get-db fdb))) + +(define (filedb:get-current-time-string) + (string-chomp (time->string (seconds->local-time (current-seconds))))) + +(define (filedb:get-base-id db path) + (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:get-path-id db path parent) + (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path parent) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:add-base db path) + (let ((existing (filedb:get-base-id db path))) + (if existing #f + (begin + (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + +;; index value field notes +;; 0 inode number st_ino +;; 1 mode st_mode bitfield combining file permissions and file type +;; 2 number of hard links st_nlink +;; 3 UID of owner st_uid as with file-owner +;; 4 GID of owner st_gid +;; 5 size st_size as with file-size +;; 6 access time st_atime as with file-access-time +;; 7 change time st_ctime as with file-change-time +;; 8 modification time st_mtime as with file-modification-time +;; 9 parent device ID st_dev ID of device on which this file resides +;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) +;; 11 block size st_blksize +;; 12 number of blocks allocated st_blocks + +(define (filedb:add-path-stat db path parent statinfo) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) + (sqlite3:execute stmt + path + parent + (vector-ref statinfo 1) ;; mode + (vector-ref statinfo 3) ;; uid + (vector-ref statinfo 4) ;; gid + (vector-ref statinfo 5) ;; size + (vector-ref statinfo 8) ;; mtime + ) + (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) + +(define (filedb:add-path db path parent) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (sqlite3:execute stmt path parent) + (sqlite3:finalize! stmt))) + +(define (filedb:register-path fdb path #!key (save-stat #f)) + (let* ((db (filedb:fdb-get-db fdb)) + (pathcache (filedb:fdb-get-pathcache fdb)) + (stat (if save-stat (file-stat path #t))) + (id (hash-table-ref/default pathcache path #f))) + (if (not db)(filedb:reopen-db fdb)) + (if id id + (let ((plist (string-split path "/"))) + (let loop ((head (car plist)) + (tail (cdr plist)) + (parent 0)) + (let ((id (filedb:get-path-id db head parent)) + (done (null? tail))) + (if id ;; we'll have a id if the path is already registered + (if done + (begin + (hash-table-set! pathcache path id) + id) ;; return the last path id for a result + (loop (car tail)(cdr tail) id)) + (begin ;; add the path and then repeat the loop with the same data + (if save-stat + (filedb:add-path-stat db head parent stat) + (filedb:add-path db head parent)) + (loop head tail parent))))))))) + +(define (filedb:update-recursively fdb path #!key (save-stat #f)) + (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) + (print "processed 0 files...") + (let loop ((l (read-line p)) + (lc 0)) ;; line count + (if (eof-object? l) + (begin + (print " " lc " files") + (close-input-port p)) + (begin + (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info + (if (= (modulo lc 100) 0) + (print " " lc " files")) + (loop (read-line p)(+ lc 1))))))) + +(define (filedb:update fdb path #!key (save-stat #f)) + ;; first get the realpath and add it to the bases table + (let ((real-path path) ;; (filedb:get-real-path path)) + (db (filedb:fdb-get-db fdb))) + (filedb:add-base db real-path) + (filedb:update-recursively fdb path save-stat: save-stat))) + +;; not used and broken +;; +(define (filedb:get-real-path path) + (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) + (pth (read-line p))) + (if (eof-object? pth) path + (begin + (close-input-port p) + pth)))) + +(define (filedb:drop-base fdb path) + (print "Sorry, I don't do anything yet")) + +(define (filedb:find-all fdb pattern action) + (let* ((db (filedb:fdb-get-db fdb)) + (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (result '())) + (sqlite3:for-each-row + (lambda (num) + (action num) + (set! result (cons num result))) stmt pattern) + (sqlite3:finalize! stmt) + result)) + +(define (filedb:get-path-record fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (partcache (filedb:fdb-get-partcache fdb)) + (dat (hash-table-ref/default partcache id #f))) + (if dat dat + (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (result #f)) + (sqlite3:for-each-row + (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (hash-table-set! partcache id result) + (sqlite3:finalize! stmt) + result)))) + +(define (filedb:get-children fdb parent-id) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" + parent-id) + res)) + +;; retrieve all that have children and those without +;; children that match patt +(define (filedb:get-children-patt fdb parent-id search-patt) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + ;; first get the children that have no children + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND + (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" + parent-id search-patt) + res)) + +(define (filedb:get-path fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (idcache (filedb:fdb-get-idcache fdb)) + (path (hash-table-ref/default idcache id #f))) + (if (not db)(filedb:reopen-db fdb)) + (if path path + (let loop ((curr-id id) + (path "")) + (let ((path-record (filedb:get-path-record fdb curr-id))) + (if (not path-record) #f ;; this id has no path + (let* ((parent-id (list-ref path-record 1)) + (pname (list-ref path-record 0)) + (newpath (string-append "/" pname path))) + (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 + (begin + (hash-table-set! idcache id newpath) + newpath) + (loop parent-id newpath))))))))) + +(define (filedb:search db pattern) + (let ((action (lambda (id)(print (filedb:get-path db id))))) + (filedb:find-all db pattern action))) + DELETED fs-transport.scm Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ /dev/null @@ -1,44 +0,0 @@ - -;; Copyright 2006-2012, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(tcp-buffer-size 2048) - -(declare (unit fs-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - - -;;====================================================================== -;; F S T R A N S P O R T S E R V E R -;;====================================================================== - -;; There is no "server" per se but a convience routine to make it non -;; necessary to be reopening the db over and over again. -;; - -(define (fs:process-queue-item packet) - (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called - (set! *megatest-db* (open-db))) - (debug:print-info 11 "fs:process-queue-item called with packet=" packet) - (db:process-queue-item *megatest-db* packet)) - Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -20,23 +20,29 @@ (let* ((c1 (map string->number (string-split color1))) (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) -(define (gutils:get-color-for-state-status state status) - (case (string->symbol state) - ((COMPLETED) - (if (equal? status "PASS") - "70 249 73" - (if (or (equal? status "WARN") - (equal? status "WAIVED")) - "255 172 13" - "223 33 49"))) ;; greenish orangeish redish - ((LAUNCHED) "101 123 142") - ((CHECK) "255 100 50") - ((REMOTEHOSTSTART) "50 130 195") - ((RUNNING) "9 131 232") - ((KILLREQ) "39 82 206") - ((KILLED) "234 101 17") - ((NOT_STARTED) "240 240 240") - (else "192 192 192"))) +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list "230 230 0" status)) + (else (list "223 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (list "240 240 240" state)) + (else (list "192 192 192" state)))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -11,32 +11,35 @@ (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) -(use spiffy uri-common intarweb http-client spiffy-request-vars) +(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) +;; Configurations for server (tcp-buffer-size 2048) +(max-connections 2048) (declare (unit http-transport)) (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) (declare (uses daemon)) +(declare (uses portlogger)) (include "common_records.scm") (include "db_records.scm") (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) -(define *server-loop-heart-beat* (current-seconds)) +(define *server-loop-heart-beat* (current-seconds)) (define *heartbeat-mutex* (make-mutex)) ;;====================================================================== ;; S E R V E R ;;====================================================================== @@ -56,310 +59,504 @@ (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) -(define (http-transport:run hostn) +(define (http-transport:run hostn run-id server-id) (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") - (exit)))) - (let* (;; (iface (if (string=? "-" hostn) - ;; #f ;; (get-host-name) - ;; hostn)) - (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily + (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) - (if ipstr ipstr hostn))) ;; hostname))) - (start-port (if (and (args:get-arg "-port") - (string->number (args:get-arg "-port"))) - (string->number (args:get-arg "-port")) - (if (and (config-lookup *configdat* "server" "port") - (string->number (config-lookup *configdat* "server" "port"))) - (string->number (config-lookup *configdat* "server" "port")) - (+ 5000 (random 1001))))) - (link-tree-path (config-lookup *configdat* "setup" "linktree"))) - (set! *cache-on* #t) + (if ipstr ipstr hostn))) ;; hostname))) + (start-port (portlogger:open-run-close portlogger:find-port)) + (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) + ;; (set! db *inmemdb*) + (debug:print-info 0 "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! - + (handle-directory spiffy-directory-listing) + ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call - (if (not db)(set! db (open-db))) + ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond + ((equal? (uri-path (request-uri (current-request))) + '(/ "api")) + (send-response body: (api:process-request *inmemdb* $) ;; the $ is the request vars proc + headers: '((content-type text/plain))) + (mutex-lock! *heartbeat-mutex*) + (set! *last-db-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*)) + ;; This is the /ctrl path where data is handed to the server and + ;; responses + ;; ((equal? (uri-path (request-uri (current-request))) + ;; '(/ "ctrl")) + ;; (let* ((packet (db:string->obj dat)) + ;; (qtype (cdb:packet-get-qtype packet))) + ;; (debug:print-info 12 "server=> received packet=" packet) + ;; (if (not (member qtype '(sync ping))) + ;; (begin + ;; (mutex-lock! *heartbeat-mutex*) + ;; (set! *last-db-access* (current-seconds)) + ;; (mutex-unlock! *heartbeat-mutex*))) + ;; ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex + ;; ;; (set! res (open-run-close db:process-queue-item open-db packet)) + ;; (set! res (db:process-queue-item db packet)) + ;; ;; (mutex-unlock! *db:process-queue-mutex*) + ;; (debug:print-info 11 "Return value from db:process-queue-item is " res) + ;; (send-response body: (conc "ctrl data\n" + ;; res + ;; "") + ;; headers: '((content-type text/plain))))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "runs")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ any)) + (send-response body: "hey there!\n" + headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) - ;; This is the /ctrl path where data is handed to the server and - ;; responses - ((equal? (uri-path (request-uri (current-request))) - '(/ "ctrl")) - (let* ((packet (db:string->obj dat)) - (qtype (cdb:packet-get-qtype packet))) - (debug:print-info 12 "server=> received packet=" packet) - (if (not (member qtype '(sync ping))) - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*))) - ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex - ;; (set! res (open-run-close db:process-queue-item open-db packet)) - (set! res (db:process-queue-item db packet)) - ;; (mutex-unlock! *db:process-queue-mutex*) - (debug:print-info 11 "Return value from db:process-queue-item is " res) - (send-response body: (conc "ctrl data\n" - res - "") - headers: '((content-type text/plain))))) (else (continue)))))))) - (http-transport:try-start-server ipaddrstr start-port))) + (http-transport:try-start-server run-id ipaddrstr start-port server-id))) ;; This is recursively run by http-transport:run until sucessful ;; -(define (http-transport:try-start-server ipaddrstr portnum) - (handle-exceptions - exn - (begin - (print-error-message exn) - (if (< portnum 9000) - (begin - (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") - (thread-sleep! 0.1) - ;; (open-run-close tasks:remove-server-records tasks:open-db) - (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) - (http-transport:try-start-server ipaddrstr (+ portnum 1))) - (print "ERROR: Tried and tried but could not start the server"))) - ;; any error in following steps will result in a retry - (set! *runremote* (list ipaddrstr portnum)) - ;; (open-run-close tasks:remove-server-records tasks:open-db) - (open-run-close tasks:server-register - tasks:open-db - (current-process-id) - ipaddrstr portnum 0 'live 'http) - (print "INFO: Trying to start server on " ipaddrstr ":" portnum) - ;; This starts the spiffy server - ;; NEED WAY TO SET IP TO #f TO BIND ALL - (start-server bind-address: ipaddrstr port: portnum) - (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) - (print "INFO: server has been stopped"))) +(define (http-transport:try-start-server run-id ipaddrstr portnum server-id) + (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) + (tdbdat (tasks:open-db))) + (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) + (handle-exceptions + exn + (begin + (print-error-message exn) + (if (< portnum 64000) + (begin + (debug:print 0 "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "exn=" (condition->list exn)) + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") + (thread-sleep! 0.1) + + ;; get_next_port goes here + (http-transport:try-start-server run-id + ipaddrstr + (portlogger:open-run-close portlogger:find-port) + server-id)) + (begin + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") + (print "ERROR: Tried and tried but could not start the server")))) + ;; any error in following steps will result in a retry + (set! *server-info* (list ipaddrstr portnum)) + (tasks:server-set-interface-port + (db:delay-if-busy tdbdat) + server-id + ipaddrstr portnum) + (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum) + ;; This starts the spiffy server + ;; NEED WAY TO SET IP TO #f TO BIND ALL + ;; (start-server bind-address: ipaddrstr port: portnum) + (if config-hostname ;; this is a hint to bind directly + (start-server port: portnum bind-address: (if (equal? config-hostname "-") + ipaddrstr + config-hostname)) + (start-server port: portnum)) + ;; (portlogger:open-run-close portlogger:set-port portnum "released") + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") + (debug:print 1 "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== -;; -;; -;; 1 Hello, world! Goodbye Dolly -;; Send msg to serverdat and receive result -(define (http-transport:client-send-receive serverdat msg) - (let* ((url (http-transport:make-server-url serverdat)) - (fullurl (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) - (numretries 0)) +(define *http-mutex* (make-mutex)) + +;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here +;; I'm pretty sure it is defunct. + +;; This next block all imported en-mass from the api branch +(define *http-requests-in-progress* 0) +(define *http-connections-next-cleanup* (current-seconds)) + +(define (http-transport:get-time-to-cleanup) + (let ((res #f)) + (mutex-lock! *http-mutex*) + (set! res (> (current-seconds) *http-connections-next-cleanup*)) + (mutex-unlock! *http-mutex*) + res)) + +(define (http-transport:inc-requests-count) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) + ;; Use this opportunity to slow things down iff there are too many requests in flight + (if (> *http-requests-in-progress* 5) + (begin + (debug:print-info 0 "Whoa there buddy, ease up...") + (thread-sleep! 1))) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count proc) + (mutex-lock! *http-mutex*) + (proc) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count-and-close-all-connections) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds + (if (> *http-requests-in-progress* 0) + (if (> etime (current-seconds)) + (begin + (thread-sleep! 0.05) + (loop etime)) + (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (close-all-connections!))) + (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:inc-requests-and-prep-to-close-all-connections) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) + +;; Send "cmd" with json payload "params" to serverdat and receive result +;; +(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) + (let* ((fullurl (if (vector? serverdat) + (http-transport:server-dat-get-api-req serverdat) + (begin + (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") + (exit 1)))) + (res #f) + (success #t)) (handle-exceptions exn - (if (< numretries 200) - (http-transport:client-send-receive serverdat msg)) + (if (> numretries 0) + (begin + (mutex-unlock! *http-mutex*) + (thread-sleep! 1) + (handle-exceptions + exn + (debug:print 0 "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") + (close-all-connections!)) + (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) + (http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1))) + (begin + (mutex-unlock! *http-mutex*) + (tasks:kill-server-run-id run-id) + #f)) (begin - (debug:print-info 11 "fullurl=" fullurl "\n") + (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here - (max-retry-attempts 100) + (max-retry-attempts 1) + ;; consider all requests indempotent (retry-request? (lambda (request) - (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) - (set! numretries (+ numretries 1)) - #t)) + #f)) ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. - (let* ((res (with-input-from-request fullurl - ;; #f - ;; msg - (list (cons 'dat msg)) - read-string))) + (let* ((send-recieve (lambda () + (mutex-lock! *http-mutex*) + ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) + ;; ((exn http client-error) e (print e))) + (set! res (vector + success + (handle-exceptions + exn + (begin + (set! success #f) + (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (hash-table-delete! *runremote* run-id) + ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine. + #f) + (with-input-from-request ;; was dat + fullurl + (list (cons 'key "thekey") + (cons 'cmd cmd) + (cons 'params params)) + read-string)))) + ;; Shouldn't this be a call to the managed call-all-connections stuff above? + (close-all-connections!) + (mutex-unlock! *http-mutex*) + )) + (time-out (lambda () + (thread-sleep! 45) + #f)) + (th1 (make-thread send-recieve "with-input-from-request")) + (th2 (make-thread time-out "time out"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (thread-terminate! th2) (debug:print-info 11 "got res=" res) - (let ((match (string-search (regexp "(.*)<.body>") res))) - (debug:print-info 11 "match=" match) - (let ((final (cadr match))) - (debug:print-info 11 "final=" final) - final))))))) + res))))) + +;; careful closing of connections stored in *runremote* +;; +(define (http-transport:close-connections run-id) + (let* ((server-dat (hash-table-ref/default *runremote* run-id #f))) + (if (vector? server-dat) + (let ((api-dat (http-transport:server-dat-get-api-uri server-dat))) + (close-connection! api-dat) + #t) + #f))) + + +(define (make-http-transport:server-dat)(make-vector 5)) +(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0)) +(define (http-transport:server-dat-get-port vec) (vector-ref vec 1)) +(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2)) +(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3)) +(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4)) +(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5)) + +(define (http-transport:server-dat-make-url vec) + (if (and (http-transport:server-dat-get-iface vec) + (http-transport:server-dat-get-port vec)) + (conc "http://" + (http-transport:server-dat-get-iface vec) + ":" + (http-transport:server-dat-get-port vec)) + #f)) + +(define (http-transport:server-dat-update-last-access vec) + (vector-set! vec 5 (current-seconds))) +;; +;; connect +;; (define (http-transport:client-connect iface port) - (let* ((login-res #f) - (serverdat (list iface port))) - (set! login-res (client:login serverdat)) - (if (and (not (null? login-res)) - (car login-res)) - (begin - (debug:print-info 0 "Logged in and connected to " iface ":" port) - (set! *runremote* serverdat) - serverdat) - (begin - (debug:print-info 0 "Failed to login or connect to " iface ":" port) - (set! *runremote* #f) - (set! *transport-type* 'fs) - #f)))) - + (let* ((api-url (conc "http://" iface ":" port "/api")) + (api-uri (uri-reference (conc "http://" iface ":" port "/api"))) + (api-req (make-request method: 'POST uri: api-uri)) + (server-dat (vector iface port api-uri api-url api-req (current-seconds)))) + server-dat)) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; -(define (http-transport:keep-running) +(define (http-transport:keep-running server-id run-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive - (let* ((server-info (let loop () + (let* ((tdbdat (tasks:open-db)) + (server-info (let loop ((start-time (current-seconds)) + (changed #t) + (last-sdat "not this")) (let ((sdat #f)) + (thread-sleep! 0.01) + (debug:print-info 0 "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) + (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat + (if (and sdat + (not changed) + (> (- (current-seconds) start-time) 2)) + sdat (begin + (debug:print-info 0 "Still waiting, last-sdat=" last-sdat) (sleep 4) - (loop)))))) + (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes + (begin + (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") + (exit)) + (loop start-time + (equal? sdat last-sdat) + sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) - (tdb (tasks:open-db)) - (spid ;;(open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f)) - (tasks:server-get-server-id tdb #f iface port #f)) - (server-timeout (let ((tmo (config-lookup *configdat* "server" "timeout"))) + (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) - ;; default to three days - (* 3 24 60 60))))) - (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; Check that iface and port have not changed (can happen if server port collides) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) - (mutex-unlock! *heartbeat-mutex*) - - (if (or (not (equal? sdat (list iface port))) - (not spid)) - (begin - (debug:print-info 0 "interface changed, refreshing iface and port info") - (set! iface (car sdat)) - (set! port (cadr sdat)) - (set! spid (tasks:server-get-server-id tdb #f iface port #f)))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) - (tasks:server-update-heartbeat tdb spid) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) - (if (> (+ last-access server-timeout) - (current-seconds)) - (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Number of cached writes " *number-of-writes*) - (debug:print-info 0 "Average cached write time " - (if (eq? *number-of-writes* 0) - "n/a (no writes)" - (/ *writes-total-delay* - *number-of-writes*)) - " ms") - (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) - (debug:print-info 0 "Average non-cached time " - (if (eq? *number-non-write-queries* 0) - "n/a (no queries)" - (/ *total-non-write-delay* - *number-non-write-queries*)) - " ms") - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) - -;; all routes though here end in exit ... -(define (http-transport:launch) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting the standalone server") - (if (args:get-arg "-daemonize") - (daemon:ize)) - (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) - (debug:print 11 "http-transport:launch hostinfo=" hostinfo) - ;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname") - (if hostinfo - (debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2)) - (if *toppath* - (let* ((th2 (make-thread (lambda () - (http-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-"))) "Server run")) - (th3 (make-thread http-transport:keep-running "Keep running")) - (th1 (make-thread server:write-queue-handler "write queue"))) - (thread-start! th2) - (thread-start! th3) - (thread-start! th1) - (set! *didsomething* #t) - (thread-join! th2)) - (debug:print 0 "ERROR: Failed to setup for megatest"))) + ;; (* 3 24 60 60) ;; default to three days + (* 60 1) ;; default to one minute + ;; (* 60 60 25) ;; default to 25 hours + )))) + (let loop ((count 0) + (server-state 'available)) + ;; Use this opportunity to sync the inmemdb to db + (let ((start-time (current-milliseconds)) + (sync-time #f) + (rem-time #f)) + ;; inmemdb is a dbstruct + (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) + (set! sync-time (- (current-milliseconds) start-time)) + (set! rem-time (quotient (- 4000 sync-time) 1000)) + (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time) + + ;; + ;; set_running after our first pass through and start the db + ;; + (if (eq? server-state 'available) + (begin + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") + (thread-sleep! 5) ;; give some margin for queries to complete before switching from file based access to server based access + (set! *inmemdb* (db:setup run-id)) + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running"))) + + (if (and (<= rem-time 4) + (> rem-time 0)) + (thread-sleep! rem-time) + (thread-sleep! 4))) ;; fallback for if the math is changed ... + + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1) 'running)) + + ;; Check that iface and port have not changed (can happen if server port collides) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *server-info*) + (mutex-unlock! *heartbeat-mutex*) + + (if (or (not (equal? sdat (list iface port))) + (not server-id)) + (begin + (debug:print-info 0 "interface changed, refreshing iface and port info") + (set! iface (car sdat)) + (set! port (cadr sdat)))) + + ;; Transfer *last-db-access* to last-access to use in checking that we are still alive + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + + ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) + ;; + ;; no_traffic, no running tests, if server 0, no running servers + ;; + ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) + ;; + (if (and *server-run* + ;; (or + (> (+ last-access server-timeout) + (current-seconds))) +;; (and (eq? run-id 0) +;; (> (tasks:num-servers-non-zero-running tdb) 0)) +;; (and (not (eq? run-id 0)) ;; only makes sense in non-zero run-id servers +;; (> (db:get-count-tests-actually-running *inmemdb* run-id) 0)) +;; )) + (begin + (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + ;; + ;; Consider implementing some smarts here to re-insert the record or kill self is + ;; the db indicates so + ;; + ;; (if (tasks:server-am-i-the-server? tdb run-id) + ;; (tasks:server-set-state! tdb server-id "running")) + ;; + (loop 0 server-state)) + (http-transport:server-shutdown server-id port))))) + +(define (http-transport:server-shutdown server-id port) + (let ((tdbdat (tasks:open-db))) + (debug:print-info 0 "Starting to shutdown the server.") + ;; need to delete only *my* server entry (future use) + (set! *time-to-exit* #t) + (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) + ;; + ;; start_shutdown + ;; + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") + (portlogger:open-run-close portlogger:set-port port "released") + (thread-sleep! 5) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Number of cached writes " *number-of-writes*) + (debug:print-info 0 "Average cached write time " + (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms") + (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 "Average non-cached time " + (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms") + (debug:print-info 0 "Server shutdown complete. Exiting") + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") (exit))) -;; (use trace) -;; (trace http-transport:keep-running -;; tasks:server-update-heartbeat -;; tasks:server-get-server-id) -;; tasks:get-best-server -;; http-transport:run -;; http-transport:launch -;; http-transport:try-start-server -;; http-transport:client-send-receive -;; http-transport:make-server-url -;; tasks:server-register -;; tasks:server-delete -;; start-server -;; hostname->ip -;; with-input-from-request -;; tasks:server-deregister-self) +;; all routes though here end in exit ... +;; +;; start_server? +;; +(define (http-transport:launch run-id) + (let* ((tdbdat (tasks:open-db))) + (set! *run-id* run-id) + (if (args:get-arg "-daemonize") + (begin + (daemon:ize) + (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it + (begin + (current-error-port *alt-log-file*) + (current-output-port *alt-log-file*))))) + (if (server:check-if-running run-id) + (begin + (debug:print 0 "INFO: Server for run-id " run-id " already running") + (exit 0))) + (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) + (remtries 4)) + (if (not server-id) + (if (> remtries 0) + (begin + (thread-sleep! 2) + (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) + (- remtries 1))) + (begin + ;; since we didn't get the server lock we are going to clean up and bail out + (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") + )) + (let* ((th2 (make-thread (lambda () + (debug:print-info 0 "Server run thread started") + (http-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + run-id + server-id)) "Server run")) + (th3 (make-thread (lambda () + (debug:print-info 0 "Server monitor thread started") + (http-transport:keep-running server-id run-id)) + "Keep running"))) + (thread-start! th2) + (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. + (thread-start! th3) + (set! *didsomething* #t) + (thread-join! th2) + (exit)))))) (define (http-transport:server-signal-handler signum) + (signal-mask! signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) - ;; (if (not *received-response*) - ;; (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") @@ -366,5 +563,64 @@ (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) + +;;====================================================================== +;; web pages +;;====================================================================== + +(define (http-transport:main-page) + (let ((linkpath (root-path))) + (conc "

" (pathname-strip-directory *toppath*) "

" + "" + "Run area: " *toppath* + "

Server Stats

" + (http-transport:stats-table) + "
" + (http-transport:runs linkpath) + "
" + (http-transport:run-stats) + "" + ))) + +(define (http-transport:stats-table) + (mutex-lock! *heartbeat-mutex*) + (let ((res + (conc "" + "" + "" + "" + "" + "" + "" + "
Max cached queries " *max-cache-size* "
Number of cached writes " *number-of-writes* "
Average cached write time " (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms
Number non-cached queries " *number-non-write-queries* "
Average non-cached time " (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms
Last access" (seconds->time-string *last-db-access*) "
"))) + (mutex-unlock! *heartbeat-mutex*) + res)) + +(define (http-transport:runs linkpath) + (conc "

Runs

" + (string-intersperse + (let ((files (map pathname-strip-directory (glob (conc linkpath "/*"))))) + (map (lambda (p) + (conc "" p "
")) + files)) + " "))) + +(define (http-transport:run-stats) + (let ((stats (open-run-close db:get-running-stats #f))) + (conc "" + (string-intersperse + (map (lambda (stat) + (conc "")) + stats) + " ") + "
" (car stat) "" (cadr stat) "
"))) ADDED index-tree.scm Index: index-tree.scm ================================================================== --- /dev/null +++ index-tree.scm @@ -0,0 +1,50 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Tests +;;====================================================================== + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tests)) +(declare (uses lock-queue)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; Populate the links tree with index.html files +;; +;; - start from most recent tests and work towards oldest -OR- +;; start from deepest hierarchy and work way up +;; - look up tests in megatest.db +;; - cross-reference the tests to stats.db +;; - if newer than event_time in stats.db or not registered in stats.db regenerate +;; - run du and store in stats.db +;; - when all tests at that level done generate next level up index.html +;; +;; include in rollup html index.html: +;; sum of du +;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc. +;; overall status +;; +;; include in test specific index.html: +;; host, uname, cpu graph, disk avail graph, steps, data +;; meta data, state, status, du +;; Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -69,13 +69,18 @@ (debug:print 6 "item-assoc->item-list x: " x) (if (< (length x) 2) (begin (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " ")) (list (car x)'())) - (let ((name (car x)) - (items (cadr x))) - (list name (string-split items))))) + (let* ((name (car x)) + (items (cadr x)) + (ilist (list name (if (string? items) + (string-split items) + '())))) + (if (null? ilist) + (debug:print 0 "ERROR: No items specified for " name)) + ilist))) itemsdat)))) (let ((debuglevel 5)) (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin @@ -131,12 +136,13 @@ (if (member item valid-values) item #f) item))) (define (items:get-items-from-config tconfig) - (let* (;; db is always at *toppath*/db/megatest.db - (items (hash-table-ref/default tconfig "items" '())) + (let* ((have-items (hash-table-ref/default tconfig "items" #f)) + (have-itable (hash-table-ref/default tconfig "itemstable" #f)) + (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) (debug:print 5 "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) @@ -145,14 +151,16 @@ (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) item)) itemstable)) + (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined")) (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) ;; (pp (item-assoc->item-list itemdat)) Index: key_records.scm ================================================================== --- key_records.scm +++ key_records.scm @@ -7,19 +7,15 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(define-inline (key:get-fieldname key)(vector-ref key 0)) -(define-inline (key:get-fieldtype key)(vector-ref key 1)) - (define-inline (keys->valslots keys) ;; => ?,?,? .... (string-intersperse (map (lambda (x) "?") keys) ",")) (define-inline (keys->key/field keys . additional) - (string-join (map (lambda (k)(conc (key:get-fieldname k) " " - (key:get-fieldtype k))) + (string-join (map (lambda (k)(conc k " TEXT")) (append keys additional)) ",")) (define-inline (item-list->path itemdat) (if (list? itemdat) (string-intersperse (map cadr itemdat) "/") Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -19,103 +19,52 @@ (declare (uses common)) (include "key_records.scm") (include "common_records.scm") -(define (get-keys db) - (let ((keys '())) ;; keys are vectors - (sqlite3:for-each-row (lambda (fieldname fieldtype) - (set! keys (cons (vector fieldname fieldtype) keys))) - db - "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC;") - (reverse keys))) ;; could just sort desc? - (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... - (string-intersperse (map key:get-fieldname keys) ",")) + (string-intersperse keys ",")) (define (args:usage . a) #f) -;; keys->vallist is called several times (quite unnecessarily), use this hash to suppress multiple -;; reporting of missing keys on the command line. -(define keys:warning-suppress-hash (make-hash-table)) - ;;====================================================================== ;; key <=> target routines ;;====================================================================== -;; this now invalidates using "/" in item names +;; This invalidates using "/" in item names. Every key will be +;; available via args:get-arg as :keyfield. Since this only needs to +;; be called once let's use it to set the environment vars +;; +;; The setting of :keyfield in args should be turned off ASAP +;; (define (keys:target-set-args keys target ht) (let ((vals (string-split target "/"))) (if (eq? (length vals)(length keys)) (for-each (lambda (key val) - (hash-table-set! ht (conc ":" (vector-ref key 0)) val)) + (setenv key val) + (hash-table-set! ht (conc ":" key) val)) keys vals) (debug:print 0 "ERROR: wrong number of values in " target ", should match " keys)) vals)) -;; given the keys (a list of vectors ) and a target return a keyval list +;; given the keys (a list of vectors or a list of keys) and a target return a keyval list ;; keyval list ( (key1 val1) (key2 val2) ...) (define (keys:target->keyval keys target) (let* ((targlist (string-split target "/")) (numkeys (length keys)) (numtarg (length targlist)) (targtweaked (if (> numkeys numtarg) (append targlist (make-list (- numkeys numtarg) "")) targlist))) (map (lambda (key targ) - (list (vector-ref key 0) targ)) - keys targtweaked))) - - -;;====================================================================== -;; key <=> args routines -;;====================================================================== - -;; Using the keys pulled from the database (initially set from the megatest.config file) -;; look for the equivalent value on the command line and add it to a list, or #f if not found. -;; default => (val1 val2 val3 ...) -;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...) -(define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE! - (let* ((keynames (map key:get-fieldname keys)) - (argkeys (map (lambda (k)(conc ":" k)) keynames)) - (withkey (not (null? withkey))) - (newremargs (args:get-args - (cons "blah" remargs) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ] - argkeys - '() - args:arg-hash - 0))) - ;;(debug:print 0 "remargs: " remargs " newremargs: " newremargs) - (apply append (map (lambda (x) - (let ((val (args:get-arg x))) - ;; (debug:print 0 "x: " x " val: " val) - (if (not val) - (begin - (if (not (hash-table-ref/default keys:warning-suppress-hash x #f)) - (begin - (debug:print 0 "WARNING: missing key " x ". Specified in database but not on command line, using \"unk\"") - (hash-table-set! keys:warning-suppress-hash x #t))) - (set! val "default"))) - (if withkey (list x val) (list val)))) - argkeys)))) - -;; Given a list of keys (list of vectors) return an alist ((key argval) ...) -(define (keys->alist keys defaultval) - (let* ((keynames (map key:get-fieldname keys)) - (newremargs (args:get-args (cons "blah" remargs) (map (lambda (k)(conc ":" k)) keynames) '() args:arg-hash 0))) ;; the cons blah works around a bug in args - (map (lambda (key) - (let ((val (args:get-arg (conc ":" key)))) - (list key (if val val defaultval)))) - keynames))) - -(define (keystring->keys keystring) - (map (lambda (x) - (let ((xlst (string-split x ":"))) - (list->vector (if (> (length xlst) 1) xlst (append (car xlst)(list "TEXT")))))) - (delete-duplicates (string-split keystring ",")))) - -(define (config-get-fields confdat) - (let ((fields (hash-table-ref/default confdat "fields" '()))) - (map (lambda (x)(vector (car x)(cadr x))) - fields))) + (list key targ)) + keys targtweaked))) + +;;====================================================================== +;; config file related routines +;;====================================================================== + +(define (keys:config-get-fields confdat) + (let ((fields (hash-table-ref/default confdat "fields" '()))) + (map car fields))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -11,18 +11,21 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) +;; (declare (uses sdb)) +(declare (uses tdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -45,36 +48,38 @@ ;; if handed a string, process it, else look for MT_CMDINFO (define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd - (read (open-input-string (base64:base64-decode enccmd))) + (common:read-encoded-string enccmd) '()))) (define (launch:execute encoded-cmd) - (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) + (let* ((cmdinfo (common:read-encoded-string encoded-cmd))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) - (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; How is testpath different from work-area ?? + (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) - (serverinf (assoc/default 'serverinf cmdinfo)) + ;; (serverinf (assoc/default 'serverinf cmdinfo)) (port (assoc/default 'port cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) + (runtlim (assoc/default 'runtlim cmdinfo)) + (item-path (item-list->path itemdat)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (keyvals #f) (fullrunscript (if (not runscript) #f @@ -85,17 +90,55 @@ (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (rollup-status 0)) (change-directory top-path) + + ;; (set-signal-handler! signal/int (lambda () + + ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, + ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* + ;; + (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) + (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) + (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (begin + (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (exit)))) + (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) - ;; Setup the *runremote* global var - (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time")) - ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) - (set! keys (cdb:remote-run db:get-keys #f)) - (set! keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) + (set! keys (rmt:get-keys)) + ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process + ;; one of these is defunct/redundant ... + (if (not (launch:setup-for-run force: #t)) + (begin + (debug:print 0 "Failed to setup, exiting") + ;; (sqlite3:finalize! db) + ;; (sqlite3:finalize! tdb) + (exit 1))) + (change-directory *toppath*) + + ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This + ;; seems non-ideal but could well break stuff + ;; BUG? BUG? BUG? + + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) + ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) + ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) + ;; Now have runconfigs data loaded, set environment vars + (for-each (lambda (section) + (for-each (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if (and (string? var)(string? val)) + (begin + (setenv var (config:eval-string-in-environment val))) ;; val) + (debug:print 0 "ERROR: bad variable spec, " var "=" val)))) + (configf:get-section rconfig section))) + (list "default" target))) + (change-directory work-area) + (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 "varpairs: " varpairs) @@ -105,40 +148,48 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) - (setenv "MT_TEST_RUN_DIR" work-area) - (setenv "MT_TEST_NAME" test-name) - (setenv "MT_ITEM_INFO" (conc itemdat)) - (setenv "MT_RUNNAME" runname) - (setenv "MT_MEGATEST" megatest) - (setenv "MT_TARGET" target) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if val + (setenv var val) + (begin + (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") + (exit))))) + (list + (list "MT_TEST_RUN_DIR" work-area) + (list "MT_TEST_NAME" test-name) + (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_ITEMPATH" item-path) + (list "MT_RUNNAME" runname) + (list "MT_MEGATEST" megatest) + (list "MT_TARGET" target) + (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) + (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) - (if (not (setup-for-run)) - (begin - (debug:print 0 "Failed to setup, exiting") - ;; (sqlite3:finalize! db) - ;; (sqlite3:finalize! tdb) - (exit 1))) ;; Can setup as client for server mode now ;; (client:setup) - (change-directory *toppath*) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process - (change-directory work-area) - - (open-run-close set-run-config-vars #f run-id keys keyvals) + ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars run-id) + (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info - (test-set-meta-info #f test-id run-id test-name itemdat 0) - (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) + ;; (tests:set-full-meta-info test-id run-id 0 work-area) + (tests:set-full-meta-info #f test-id run-id 0 work-area 10) + + (thread-sleep! 0.3) ;; NFS slowness has caused grief here + (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -148,18 +199,30 @@ (let* ((m (make-mutex)) (kill-job? #f) (exit-info (vector #t #t #t)) (job-thread #f) + (keep-going #t) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) - (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; Since we should have a clean slate at this time there is no need to do + ;; any of the other stuff that tests:test-set-status! does. Let's just + ;; force RUNNING/n/a + + + (thread-sleep! 0.3) + (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING") + (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) + (rmt:test-set-top-process-pid run-id test-id pid) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) @@ -175,10 +238,11 @@ ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -207,14 +271,14 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - ;; DO NOT remote - (db:teststep-set-status! #f test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) + (rmt:test-set-top-process-pid run-id test-id pid) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) @@ -225,14 +289,13 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used - (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) + (rmt:test-set-log! run-id test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -242,26 +305,32 @@ (else 'fail))) (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) - (else 'fail)))) + (else 'fail))) + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING"))) + ) (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! test-id "RUNNING" "WARN" + (tests:test-set-status! run-id test-id next-state "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) + (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail - (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" + (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -272,102 +341,159 @@ (round (- (current-seconds) start-seconds))))) (kill-tries 0)) + ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) + ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) + (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes))) (begin - (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) - ;; open-run-close not needed for test-set-meta-info - (test-set-meta-info #f test-id run-id test-name itemdat minutes) + (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) + (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) + (time-exceeded (> run-seconds runtlim))) + (if time-exceeded + (begin + (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) + #t) + #f))))) + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f) (if kill-job? (begin (mutex-lock! m) - (let* ((pid (vector-ref exit-info 0))) - (if (number? pid) - (begin - (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") - (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) - (for-each - (lambda (p) - (let* ((parts (string-split p)) - (p-id (if (> (length parts) 0) - (string->number (car parts)) - #f))) - (if p-id - (begin - (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) - (system (conc "kill -9 " p-id)))))) - (car processes)) - (system (conc "kill -9 -" pid)))) - (begin - (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") - (tests:test-set-status! test-id "KILLED" "FAIL" - (args:get-arg "-m") #f) - (sqlite3:finalize! tdb) - (exit 1)))) - (set! kill-tries (+ 1 kill-tries)) - (mutex-unlock! m))) - ;; (sqlite3:finalize! db) - (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses - (loop (calc-minutes))))))) - (th1 (make-thread monitorjob)) - (th2 (make-thread runit))) + ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this + ;; section and the runit section? Or add a loop that tries three times with a 1/4 second + ;; between tries? + (let* ((pid1 (vector-ref exit-info 0)) + (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pids (delete-duplicates (filter number? (list pid1 pid2))))) + (if (not (null? pids)) + (begin + (for-each + (lambda (pid) + (handle-exceptions + exn + (begin + (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") + (if (process:alive? pid) + (begin + (process-signal pid signal/int) + (thread-sleep! 5) + (if (process:process-alive? pid) + (process-signal pid signal/kill)))))) + pids) + (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) + (begin + (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) + ))) + (mutex-unlock! m) + ;; no point in sticking around. Exit now. + (exit))) + (if keep-going + (begin + (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (if keep-going + (loop (calc-minutes))))))) + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (th1 (make-thread monitorjob "monitor job")) + (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) + (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") + (set! keep-going #f) + (thread-join! th1) + (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + ;; only state and status needed - use lazy routine + (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? - (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) - (begin - (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (tests:test-set-status! test-id - (if kill-job? "KILLED" "COMPLETED") - (cond + (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + ;; "COMPLETED" + ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ) + (new-status (cond ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) - ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) + ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - (else "FAIL")) - (args:get-arg "-m") #f))) + (else "FAIL")))) ;; (db:test-get-status testinfo))) + (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) + (tests:test-set-status! run-id + test-id + new-state + new-status + (args:get-arg "-m") #f) + ;; need to update the top test record if PASS or FAIL and this is a subtest + ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! + )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no - ) + (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) - ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) - ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") - ;; (sqlite3:finalize! db) - ;; (sqlite3:finalize! tdb) (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. -(define (setup-for-run) +(define (launch:setup-for-run #!key (force #f)) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to ;; pass on that idea for now ;; special case - (set! *configinfo* (find-and-read-config - (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME")) - (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) - (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (if *toppath* - (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated - (debug:print 0 "ERROR: failed to find the top path to your run setup.")) + (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call + (begin + (set! *configinfo* (find-and-read-config + (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") + environ-patt: "env-override" + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME")) + (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) + (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) + (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical + (if linktree + (if (not (file-exists? linktree)) + (begin + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (exit 1)) + (create-directory linktree #t)))) + (begin + (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") + (exit 1))) + (if linktree + (let ((dbdir (conc linktree "/.db"))) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) + (if (not (directory-exists? dbdir))(create-directory dbdir))) + (setenv "MT_LINKTREE" linktree)) + (begin + (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") + (exit 1))) + (if (and *toppath* + (directory-exists? *toppath*)) + (setenv "MT_RUN_AREA_HOME" *toppath*) + (begin + (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") + (exit 1)))))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) (best #f) @@ -374,25 +500,35 @@ (bestsize 0)) (if disks (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) - (freespc (if (and (directory? dirpath) - (file-write-access? dirpath)) - (get-df dirpath) - (begin - (debug:print 0 "WARNING: path " dirpath " in [disks] section not valid or writable") - 0)))) + (freespc (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 50 "disks not a dir " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 50 "disks not writeable " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 50 "disks not a proper path " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) + -1) + (else + (get-df dirpath))))) (if (> freespc bestsize) (begin (set! best dirpath) (set! bestsize freespc))))) (map car disks))) - (if best + (if (and best (> bestsize 0)) best (begin - (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section") + (if (common:low-noise-print 20 "no valid disks") + (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!")) (exit 1))))) ;; Desired directory structure: ;; ;; - - -. @@ -406,19 +542,17 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area db run-id test-id test-src-path disk-path testname itemdat) - (let* ((run-info (cdb:remote-run db:get-run-info #f run-id)) - (item-path (item-list->path itemdat)) - (runname (db:get-value-by-header (db:get-row run-info) +(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) + (let* ((item-path (item-list->path itemdat)) + (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) ;; convert back to db: from rdb: - this is always run at server end - (key-vals (cdb:remote-run db:get-key-vals #f run-id)) - (target (string-intersperse key-vals "/")) + (target (string-intersperse (map cadr keyvals) "/")) (not-iterated (equal? "" item-path)) ;; all tests are found at /test-base or /test-base (testtop-base (conc target "/" runname "/" testname)) @@ -430,46 +564,34 @@ ;; ensure this exists first as links to subtests must be created there (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) (if rd rd (conc *toppath* "/runs")))) - (lnkbase (conc linktree "/" target "/" runname)) - (lnkpath (conc lnkbase "/" testname)) - (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) + (lnkbase (conc linktree "/" target "/" runname)) + (lnkpath (conc lnkbase "/" testname)) + (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) + (lnktarget (conc lnkpath "/" item-path))) - ;; Update the rundir path in the test record for all - (cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf) + ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical + ;; rundir shortdir + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... - (if (not (directory-exists? lnkbase)) + (if (and (not (directory-exists? lnkbase)) + (not (file-exists? lnkbase))) (create-directory lnkbase #t)) ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially ;; thousands of unnecessary updates, cache the fact it was set and don't set it ;; again. - ;; NB - This is not working right - some top tests are not getting the path set!!! - - (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path)) - (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) - (hash-table-set! *toptest-paths* testname curr-test-path) - ;; NB// Was this for the test or for the parent in an iterated test? - (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path) - (if (or (not curr-test-path) - (not (directory-exists? toptest-path))) - (begin - (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) - (create-directory toptest-path #t) - (hash-table-set! *toptest-paths* testname toptest-path))))) - ;; Now create the link from the test path to the link tree, however ;; if the test is iterated it is necessary to create the parent path ;; to the iteration. use pathname-directory to trim the path by one ;; level (if (not not-iterated) ;; i.e. iterated @@ -497,14 +619,42 @@ (begin (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) + ;; NB - This was not working right - some top tests are not getting the path set!!! + ;; + ;; Do the setting of this record after the paths are created so that the shortdir can + ;; be set to the real directory location. This is safer for future clean up if the link + ;; tree is damaged or lost. + ;; + (if (not (hash-table-ref/default *toptest-paths* testname #f)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (curr-test-path (if testinfo ;; (filedb:get-path *fdb* + ;; (db:get-path dbstruct + ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir testinfo) ;; ) ;; ) + #f))) + (hash-table-set! *toptest-paths* testname curr-test-path) + ;; NB// Was this for the test or for the parent in an iterated test? + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath + (if (file-exists? lnkpath) + (resolve-pathname lnkpath) + lnkpath) + testname "") + ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) + (if (or (not curr-test-path) + (not (directory-exists? toptest-path))) + (begin + (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) + (create-directory toptest-path #t) + (hash-table-set! *toptest-paths* testname toptest-path))))) + ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test - (let ((lnktarget (conc lnkpath "/" item-path))) + (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) (debug:print 2 "Setting up sub test run area") (debug:print 2 " - creating run area in " test-path) (handle-exceptions exn (begin @@ -517,134 +667,153 @@ ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) - ;; I suspect this section was deleting test directories under some - ;; wierd sitations? This doesn't make sense - reenabling the rm -f - ;; I honestly don't remember *why* this chunk was needed... - ;; (let ((testlink (conc lnkpath "/" testname))) - ;; (if (and (file-exists? testlink) - ;; (or (regular-file? testlink) - ;; (symbolic-link? testlink))) - ;; (system (conc "rm -f " testlink))) - ;; (system (conc "ln -sf " test-path " " testlink))) + (if (not (directory? test-path)) + (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes + (if (directory? test-path) (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path - (string-substitute "TEST_SRC_PATH" test-src-path cmd)) + (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) #f))) (cmd (if ovrcmd ovrcmd - (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"))) + (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" + " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) (debug:print 2 "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) - (list #f #f)))) + (if (> remtries 0) + (begin + (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + ;; + (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) + (list #f #f))))) ;; 1. look though disks list for disk with most space ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) -(define (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat params) +(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) ;; (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) ;; (list "MT_TARGET" mt_target) )) - (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) - (launcher (config-lookup *configdat* "jobtools" "launcher")) - (runscript (config-lookup test-conf "setup" "runscript")) - (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big - (diskspace (config-lookup test-conf "requirements" "diskspace")) - (memory (config-lookup test-conf "requirements" "memory")) - (hosts (config-lookup *configdat* "jobtools" "workhosts")) + (let* ((useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) + (if ush + (if (equal? ush "no") ;; must use "no" to NOT use shell + #f + ush) + #t))) ;; default is yes + (launcher (config-lookup *configdat* "jobtools" "launcher")) + (runscript (config-lookup test-conf "setup" "runscript")) + (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big + (diskspace (config-lookup test-conf "requirements" "diskspace")) + (memory (config-lookup test-conf "requirements" "memory")) + (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) + (run-time-limit (or (configf:lookup test-conf "requirements" "runtimelim") + (configf:lookup *configdat* "setup" "runtimelim"))) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (conc (if dir (conc dir "/") "") (case (string->symbol exe) - ((dboard) "megatest") - ((mtest) "megatest") + ((dboard) "../megatest") + ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) - (test-sig (conc test-name ":" (item-list->path itemdat))) ;; test-path is the full path including the item-path + (item-path (item-list->path itemdat)) + (test-sig (conc test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) - (item-path (item-list->path itemdat)) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id)) - (mt_target (string-intersperse (map cadr keyvallst) "/")) + ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) + (testinfo (rmt:get-test-info-by-id run-id test-id)) + (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) + (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test + (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run + (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir + (begin + (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) + (runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record + + ;; prevent overlapping actions - set to LAUNCHED as early as possible + ;; + (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED") (set! diskpath (get-best-disk *configdat*)) (if diskpath - (let ((dat (open-run-close create-work-area db run-id test-id test-path diskpath test-name itemdat))) + (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) (debug:print-info 2 "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode - (with-output-to-string - (lambda () ;; (list 'hosts hosts) - (write (list (list 'testpath test-path) - ;; (list 'runremote *runremote*) - (list 'transport (conc *transport-type*)) - (list 'serverinf *server-info*) - (list 'toppath *toppath*) - (list 'work-area work-area) - (list 'test-name test-name) - (list 'runscript runscript) - (list 'run-id run-id ) - (list 'test-id test-id ) - (list 'itemdat itemdat ) - (list 'megatest remote-megatest) - (list 'ezsteps ezsteps) - (list 'target mt_target) - (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) - (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) - (list 'runname runname) - (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) + (z3:encode-buffer + (with-output-to-string + (lambda () ;; (list 'hosts hosts) + (write (list (list 'testpath test-path) + (list 'transport (conc *transport-type*)) + ;; (list 'serverinf *server-info*) + (list 'toppath *toppath*) + (list 'work-area work-area) + (list 'test-name test-name) + (list 'runscript runscript) + (list 'run-id run-id ) + (list 'test-id test-id ) + ;; (list 'item-path item-path ) + (list 'itemdat itemdat ) + (list 'megatest remote-megatest) + (list 'ezsteps ezsteps) + (list 'target mt_target) + (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) + (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) + (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) + (list 'runname runname) + (list 'mt-bindir-path mt-bindir-path)))))))) + ;; clean out step records from previous run if they exist - ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") - ;; (open-run-close db:delete-test-step-records db test-id) + ;; (rmt:delete-test-step-records run-id test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir - (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher @@ -666,36 +835,48 @@ (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) + (list "MT_ITEMPATH" item-path) ) itemdat))) - (launch-results (apply cmd-run-with-stderr->list ;; cmd-run-proc-each-line + ;; Launchwait defaults to true, must override it to turn off wait + (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) + (launch-results (apply (if launchwait + cmd-run-with-stderr->list + process-run) (if useshell - (string-intersperse fullcmd " ") + (let ((cmdstr (string-intersperse fullcmd " "))) + (if launchwait + cmdstr + (conc cmdstr " >> mt_launch.log 2>&1"))) (car fullcmd)) - ;; conc (if useshell '() - (cdr fullcmd))))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) + (cdr fullcmd))))) + (if (not launchwait) ;; give the OS a little time to allow the process to start + (thread-sleep! 0.01)) (with-output-to-file "mt_launch.log" (lambda () - (apply print launch-results))) + (if (list? launch-results) + (apply print launch-results) + (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) + #:append)) (debug:print 2 "Launching completed, updating db") (debug:print 2 "Launch results: " launch-results) (if (not launch-results) - (begin - (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") - ;; (sqlite3:finalize! db) - ;; good ole "exit" seems not to work - ;; (_exit 9) - ;; but this hack will work! Thanks go to Alan Post of the Chicken email list - ;; NB// Is this still needed? Should be safe to go back to "exit" now? - (process-signal (current-process-id) signal/kill) - )) + (begin + (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") + ;; (sqlite3:finalize! db) + ;; good ole "exit" seems not to work + ;; (_exit 9) + ;; but this hack will work! Thanks go to Alan Post of the Chicken email list + ;; NB// Is this still needed? Should be safe to go back to "exit" now? + (process-signal (current-process-id) signal/kill) + )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results)) (change-directory *toppath*)) ADDED lock-queue.scm Index: lock-queue.scm ================================================================== --- /dev/null +++ lock-queue.scm @@ -0,0 +1,229 @@ +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use sqlite3 srfi-18) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit lock-queue)) +(declare (uses common)) +(declare (uses tasks)) + +;;====================================================================== +;; attempt to prevent overlapping updates of rollup files by queueing +;; update requests in an sqlite db +;;====================================================================== + +;;====================================================================== +;; db record, +;;====================================================================== + +(define (make-lock-queue:db-dat)(make-vector 3)) +(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) +(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) +(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) + +(define (lock-queue:open-db fname #!key (count 10)) + (let* ((actualfname (conc fname ".lockdb")) + (dbexists (file-exists? actualfname)) + (db (sqlite3:open-database actualfname)) + (handler (make-busy-timeout 136000))) + (if dbexists + (vector db actualfname) + (begin + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:open-db fname count: (- count 1)) + (vector db actualfname))) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS queue ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + start_time INTEGER, + state TEXT, + CONSTRAINT queue_constraint UNIQUE (test_id));") + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS runlocks ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + run_lock TEXT, + CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) + (sqlite3:set-busy-handler! db handler) + (vector db actualfname))) + +(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 30) + (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) + (begin + (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" + newstate + test-id))) + +(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 "WARNING: exception on lock-queue:any-younger. Trying again in 30 seconds.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 30) + (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) + (begin + (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (tid) + ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as + (if (not (equal? tid test-id)) + (set! res tid))) + (lock-queue:db-dat-get-db dbdat) + "SELECT test_id FROM queue WHERE start_time > ?;" mystart) + res))) + +(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") + (let* ((res #f) + (db (lock-queue:db-dat-get-db dbdat)) + (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) + (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) + (let ((result + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: failed to get queue lock. Will try again in a few seconds") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 10) + (if (> count 0) + (lock-queue:get-lock dbdat test-id count: (- count 1))) + #f) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tid lockstate) + (set! res (list tid lockstate))) + lckqry) + (if res + (if (equal? (car res) test-id) + #t ;; already have the lock + #f) + (begin + (sqlite3:execute mklckqry test-id) + ;; if no error handled then return #t for got the lock + #t))))))) + (sqlite3:finalize! lckqry) + (sqlite3:finalize! mklckqry) + result))) + +(define (lock-queue:release-lock fname test-id #!key (count 10)) + (let* ((dbdat (lock-queue:open-db fname))) + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! (/ count 10)) + (if (> count 0) + (begin + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) + (lock-queue:release-lock fname test-id count: (- count 1))) + (let ((journal (conc fname "-journal"))) + ;; If we've tried ten times and failed there is a serious problem + ;; try to remove the lock db and allow it to be recreated + (handle-exceptions + exn + #f + (if (file-exists? journal)(delete-file journal)) + (if (file-exists? fname) (delete-file fname)) + #f)))) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) + +(define (lock-queue:steal-lock dbdat test-id #!key (count 10)) + (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 10) + (if (> count 0) + (lock-queue:steal-lock dbdat test-id count: (- count 1)) + #f)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) + (lock-queue:get-lock dbdat test-it)) + +;; returns #f if ok to skip the task +;; returns #t if ok to proceed with task +;; otherwise waits +;; +(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f)) + (let* ((dbdat (lock-queue:open-db fname)) + (mystart (current-seconds)) + (db (lock-queue:db-dat-get-db dbdat))) + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (thread-sleep! 10) + (if (> count 0) + (begin + (sqlite3:finalize! db) + (lock-queue:wait-turn fname test-id count: (- count 1))) + (begin + (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (print-call-chain (current-error-port)) + #f))) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") + (sqlite3:execute + db + "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" + test-id mystart) + (thread-sleep! 1) ;; give other tests a chance to register + (let ((result + (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) + (if younger-waiting + (begin + ;; no need for us to wait. mark in the lock queue db as skipping + (lock-queue:set-state dbdat test-id "skipping") + #f) ;; let the calling process know that nothing needs to be done + (if (lock-queue:get-lock dbdat test-id) + #t + (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock + (lock-queue:steal-lock dbdat test-id) + (begin + (thread-sleep! 1) + (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) + (sqlite3:finalize! db) + result)))) + + +;; (use trace) +;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -17,12 +17,12 @@ (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) (define (args:get-arg-from ht arg . default) (if (null? default) - (hash-table-ref/default ht arg #f)) - (hash-table-ref/default ht arg (car default))) + (hash-table-ref/default ht arg #f) + (hash-table-ref/default ht arg (car default)))) (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) @@ -34,11 +34,12 @@ (define (args:get-args args params switches arg-hash num-needed) (let* ((numargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) (if (< numargs (if adj-num-needed adj-num-needed 2)) (if (>= num-needed 1) - (args:usage "No arguments provided")) + (args:usage "No arguments provided") + '()) (let loop ((arg (cadr args)) (tail (cddr args)) (remargs '())) (cond ((member arg params) ;; args with params Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ -;; Always use two digit decimal -;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. +;; Always use two or four digit decimal +;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5417) +(define megatest-version 1.6006) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,11 +8,13 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json) ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json + http-client directory-utils z3 srfi-18) ;; extras) + (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; (use zmq) @@ -24,40 +26,33 @@ (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) +(declare (uses db)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) +(declare (uses tdb)) +(declare (uses mt)) +(declare (uses api)) +(declare (uses tasks)) ;; only used for debugging. (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") +(include "run_records.scm") (include "megatest-fossil-hash.scm") -;; (use trace dot-locking) -;; (trace -;; cdb:client-call -;; cdb:remote-run -;; cdb:test-set-status-state -;; change-directory -;; db:process-queue-item -;; db:test-get-logfile-info -;; db:teststep-set-status! -;; nice-path -;; obtain-dot-lock -;; open-run-close -;; read-config -;; runs:can-run-more-tests -;; sqlite3:execute -;; sqlite3:for-each-row -;; tests:check-waiver-eligibility -;; tests:summarize-items -;; tests:test-set-status! -;; thread-sleep! -;;) - +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +;; Disabled help items +;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) +;; from prior runs with same keys (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -68,26 +63,28 @@ Launching and managing runs -runall : run all tests that are not state COMPLETED and status PASS, CHECK or KILLED -runtests tst1,tst2 ... : run tests - -remove-runs : remove the data for a run, requires :runname and -testpatt + -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) - -rollup : (currently disabled) fill run (set by :runname) with latest test(s) - from prior runs with same keys -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname + -set-run-status status : sets status for run to status, requires -target and -runname + -get-run-status : gets status for run specified by target and runname + -run-wait : wait on run specified by target and runname + -preclean : remove the existing test directory before running the test Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard - :runname : required, name for this particular test run - :state : Applies to runs, tests or steps depending on context - :status : Applies to runs, tests or steps depending on context + -runname : required, name for this particular test run + -state : Applies to runs, tests or steps depending on context + -status : Applies to runs, tests or steps depending on context Test helpers (for use inside tests) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test @@ -108,36 +105,51 @@ from standard in. Each line is comma delimited with four fields category,variable,value,comment Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard - -showkeys : show the keys used in this megatest setup - -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/%... + -show-keys : show the keys used in this megatest setup + -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/%... returns list sorted by age ascending, see examples below -test-paths : get the test paths matching target, runname, item and test patterns. -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr + -show-cmdinfo : dump the command info for a test (run in test environment) + -section sectionName + -var varName : for config and runconfig lookup value for sectionName varName Misc + -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date + -cleanup-db : remove any orphan records, vacuum the db + -import-megatest.db : migrate a database from v1.55 series to v1.60 series + -sync-to-megatest.db : migrate data back to megatest.db -update-meta : update the tests metadata for all tests - -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname - -transport http|fs : use http or direct access for transport (default is http) -daemonize : fork into background and disconnect from stdin/out + -log logfile : send stdout and stderr to logfile -list-servers : list the servers - -stop-server id : stop server specified by id (see output of -list-servers) + -stop-server id : stop server specified by id (see output of -list-servers), use + 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm + -mark-incompletes : find and mark incomplete tests + -ping run-id|host:port : ping server, exit with 0 if found + +Utilities + -env2file fname : write the environment to fname.csh and fname.sh + -refdb2dat refdb : convert refdb to sexp or to format specified by -dumpmode + formats: perl, ruby, sqlite3 + -o : output file for refdb2dat (defaults to stdout) Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -148,11 +160,11 @@ -gen-megatest-test tname : create a skeleton megatest test. You will be prompted for info Examples # Get test path, use '.' to get a single path or a specific path/file pattern -megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt% +megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% Called as " (string-intersperse (argv) " ") " Version " megatest-version ", built from " megatest-fossil-hash )) ;; -gui : start a gui interface @@ -163,11 +175,10 @@ (argv) (list "-runtests" ;; run a specific test "-config" ;; override the config file name "-execute" ;; run the command encoded in the base64 parameter "-step" - ":runname" "-target" "-reqtarg" ":runname" "-runname" ":state" @@ -192,77 +203,179 @@ ":value" ":expected" ":tol" ":units" ;; misc + "-start-dir" "-server" - "-transport" "-stop-server" "-port" "-extract-ods" "-pathmod" "-env2file" "-setvars" "-set-state-status" + "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file + "-section" + "-var" "-dumpmode" + "-run-id" + "-ping" + "-refdb2dat" + "-o" + "-log" ) - (list "-h" + (list "-h" "-help" "--help" "-version" "-force" "-xterm" "-showkeys" + "-show-keys" "-test-status" "-set-values" "-load-test-data" "-summarize-items" "-gui" "-daemonize" + "-preclean" ;; misc "-archive" "-repl" "-lock" "-unlock" "-list-servers" - ;; mist queries + "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + + ;; misc queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" + "-show-cmdinfo" + "-get-run-status" + ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" "-rebuild-db" + "-cleanup-db" "-rollup" "-update-meta" "-gen-megatest-area" + "-mark-incompletes" + + "-convert-to-norm" + "-convert-to-old" + "-import-megatest.db" + "-sync-to-megatest.db" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) -(if (args:get-arg "-h") +;; The watchdog is to keep an eye on things like db sync etc. +;; +(define *watchdog* + (make-thread + (lambda () + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))) + (let loop () + ;; sync for filesystem local db writes + ;; + (let ((start-time (current-seconds)) + (servers-started (make-hash-table))) + (for-each + (lambda (run-id) + (mutex-lock! *db-multi-sync-mutex*) + (if (and legacy-sync + (hash-table-ref/default *db-local-sync* run-id #f)) + ;; (if (> (- start-time last-write) 5) ;; every five seconds + (begin ;; let ((sync-time (- (current-seconds) start-time))) + (db:multi-db-sync (list run-id) 'new2old) + (if (common:low-noise-print 30 "sync new to old") + (let ((sync-time (- (current-seconds) start-time))) + (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run + ;; (begin + ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; (server:kind-run run-id))))) + (hash-table-delete! *db-local-sync* run-id))) + (mutex-unlock! *db-multi-sync-mutex*)) + (hash-table-keys *db-local-sync*))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (begin + (thread-sleep! 1) ;; wait one second before syncing again + (loop))))) + "Watchdog thread"))) + +(thread-start! *watchdog*) + +(if (args:get-arg "-log") + (let ((oup (open-output-file (args:get-arg "-log")))) + (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) + (current-error-port oup) + (current-output-port oup))) + +(if (or (args:get-arg "-h") + (args:get-arg "-help") + (args:get-arg "--help")) (begin (print help) (exit))) + +(if (args:get-arg "-start-dir") + (if (file-exists? (args:get-arg "-start-dir")) + (change-directory (args:get-arg "-start-dir")) + (begin + (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) (if (args:get-arg "-version") (begin (print megatest-version) (exit))) (define *didsomething* #f) + +;; Overall exit handling setup immediately +;; +(if (or (args:get-arg "-process-reap")) + ;; (args:get-arg "-runtests") + ;; (args:get-arg "-execute") + ;; (args:get-arg "-remove-runs") + ;; (args:get-arg "-runstep")) + (let ((original-exit (exit-handler))) + (exit-handler (lambda (#!optional (exit-code 0)) + (printf "Preparing to exit with exit code ~A ...\n" exit-code) + (for-each + (lambda (pid) + (handle-exceptions + exn + #t + (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) + (if (or (eq? pid-val pid) + (eq? pid-val 0)) + (begin + (printf "Sending signal/term to ~A\n" pid) + (process-signal pid signal/term)))))) + (process:children #f)) + (original-exit exit-code))))) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== @@ -276,10 +389,12 @@ (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) + +(on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -287,110 +402,178 @@ (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") - (begin + (let ((toppath (launch:setup-for-run))) (print (string-intersperse (map (lambda (x) (string-intersperse x " => ")) - (common:get-disks) ) + (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) +(if (args:get-arg "-refdb2dat") + (let* ((input-db (args:get-arg "-refdb2dat")) + (out-file (args:get-arg "-o")) + (out-fmt (or (args:get-arg "-dumpmode") "scheme")) + (out-port (if (and out-file + (not (equal? out-fmt "sqlite3"))) + (open-output-file out-file) + (current-output-port))) + (res-data (configf:read-refdb input-db)) + (data (car res-data)) + (msg (cadr res-data))) + (if (not data) + (debug:print 0 data) ;; some error occurred + (with-output-to-port out-port + (lambda () + (case (string->symbol out-fmt) + ((scheme)(pp data)) + ((perl) + ;; (print "%hash = (") + ;; key1 => 'value1', + ;; key2 => 'value2', + ;; key3 => 'value3', + ;; ); + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) + ((python ruby) + (print "data={}") + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) + initproc1: + (lambda (sheetname) + (print "data[\"" sheetname "\"] = {}")) + initproc2: + (lambda (sheetname sectionname) + (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) + ((sqlite3) + (let* ((db-file (or out-file (pathname-file input-db))) + (db-exists (file-exists? db-file)) + (db (sqlite3:open-database db-file))) + (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (sqlite3:execute db + "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" + sheetname sectionname varname val))) + (sqlite3:finalize! db))) + (else + (pp data)))))) + (if out-file (close-output-port out-port)) + (exit) ;; yes, bending the rules here - need to exit since this is a utility + )) + +(if (args:get-arg "-ping") + (let* ((run-id (string->number (args:get-arg "-run-id"))) + (host:port (args:get-arg "-ping"))) + (server:ping run-id host:port))) + ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== (if (args:get-arg "-server") - (let ((transport (args:get-arg "-transport" "http"))) - (debug:print 2 "Launching server using transport " transport) - (server:launch (string->symbol transport))) - (if (not (null? (lset-intersection + + ;; Server? Start up here. + ;; + (let ((tl (launch:setup-for-run)) + (run-id (and (args:get-arg "-run-id") + (string->number (args:get-arg "-run-id"))))) + (if run-id + (begin + (server:launch run-id) + (set! *didsomething* #t)) + (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) + + ;; Not a server? This section will decide how to communicate + ;; + ;; Setup client for all expect listed here + (if (null? (lset-intersection equal? (hash-table-keys args:arg-hash) - '("-runtests" "-list-runs" "-rollup" - "-remove-runs" "-lock" "-unlock" - "-update-meta" "-extract-ods")))) - (if (setup-for-run) - (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) - (trycount 0)) - (if (or (not servers) - (null? servers)) - (begin - (if (eq? trycount 0) ;; just do the server start once - (begin - (debug:print 0 "INFO: Starting server as none running ...") - ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) - ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) - (process-fork (lambda () - (daemon:ize) - (server:launch (string->symbol (args:get-arg "-transport" "http"))))) - (thread-sleep! 3)) - (debug:print-info 0 "Waiting for server to start")) - (loop (open-run-close tasks:get-best-server tasks:open-db) - (+ trycount 1))) - (debug:print 0 "INFO: Server(s) running " servers) - ))))) + '("-list-servers" + "-stop-server" + "-show-cmdinfo" + "-list-runs"))) + (if (launch:setup-for-run) + (let ((run-id (and (args:get-arg "-run-id") + (string->number (args:get-arg "-run-id"))))) + ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) + ;; if not list or kill then start a client (if appropriate) + (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") + (eq? (length (hash-table-keys args:arg-hash)) 0)) + (debug:print-info 1 "Server connection not needed") + (begin + ;; (if run-id + ;; (client:launch run-id) + ;; (client:launch 0) ;; without run-id we'll start a server for "0" + #t + )))))) + +;; MAY STILL NEED THIS +;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) - (let ((tl (setup-for-run))) + (let ((tl (launch:setup-for-run))) (if tl - (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db)) - (fmtstr "~5a~8a~8a~20a~20a~10a~10a~10a~10a~10a\n") + (let* ((tdbdat (tasks:open-db)) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) + (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) (killinfo (args:get-arg "-stop-server")) (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) - (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface" "OutPort" "InPort" "LastBeat" "State" "Transport") - (format #t fmtstr "==" "=====" "===" "====" "=========" "=======" "======" "========" "=====" "=========") + (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") + (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") (for-each (lambda (server) (let* ((id (vector-ref server 0)) (pid (vector-ref server 1)) (hostname (vector-ref server 2)) - (interface (vector-ref server 3)) + (interface (vector-ref server 3)) (pullport (vector-ref server 4)) (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port)) + (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct ;; server (if (equal? state "dead") (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day. - (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete)) + (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete)) (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds - (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid))) - (format #t fmtstr id mt-ver pid hostname interface pullport pubport last-update + (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid))) + (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) - (if (equal? id sid) + (if (or (equal? id sid) + (equal? sid 0)) ;; kill all/any (begin (debug:print-info 0 "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) (debug:print-info 1 "Done with listservers") (set! *didsomething* #t) (exit)) ;; must do, would have to add checks to many/all calls below - (exit))) - ;; if not list or kill then start a client (if appropriate) - (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") - (eq? (length (hash-table-keys args:arg-hash)) 0)) - (debug:print-info 1 "Server connection not needed") - ;; ok, so lets connect to the server - (client:launch))) + (exit)))) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== @@ -400,118 +583,182 @@ (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) + +(define (full-runconfigs-read) + (let* ((keys (rmt:get-keys)) + (target (common:args-get-target)) + (key-vals (if target (keys:target->keyval keys target) #f)) + (sections (if target (list "default" target) #f)) + (data (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (if key-vals + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals)) + (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + data)) + (if (args:get-arg "-show-runconfig") - (let* ((target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - #f))) - (sections (if target (list "default" target) #f)) - (data (read-config "runconfigs.config" #f #t sections: sections))) - - ;; keep this one local - (cond - ((not (args:get-arg "-dumpmode")) - (pp (hash-table->alist data))) - ((string=? (args:get-arg "-dumpmode") "json") + (let ((tl (launch:setup-for-run))) + (push-directory *toppath*) + (let ((data (full-runconfigs-read))) + ;; keep this one local + (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) + (if val (print val)))) + ((not (args:get-arg "-dumpmode")) + (pp (hash-table->alist data))) + ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) - (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t))) + (else + (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t)) + (pop-directory))) (if (args:get-arg "-show-config") - (let ((data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (let ((tl (launch:setup-for-run)) + (data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (push-directory *toppath*) ;; keep this one local (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) + (if val (print val)))) ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t))) + (set! *didsomething* #t) + (pop-directory))) + +(if (args:get-arg "-show-cmdinfo") + (if (getenv "MT_CMDINFO") + (let ((data (common:read-encoded-string (getenv "MT_CMDINFO")))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t)) + (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first (define (operate-on action) - (cond - ((not (args:get-arg ":runname")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") - (exit 2)) - ((not (args:get-arg "-testpatt")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") - (exit 3)) - (else - (if (not (car *configinfo*)) - (begin - (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (runs:operate-on action - (args:get-arg ":runname") - (args:get-arg "-testpatt") - state: (args:get-arg ":state") - status: (args:get-arg ":status") - new-state-status: (args:get-arg "-set-state-status"))) - (set! *didsomething* #t)))) + (let* ((runrec (runs:runrec-make-record)) + (target (common:args-get-target))) + (cond + ((not target) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (exit 1)) + ((not (or (args:get-arg ":runname") + (args:get-arg "-runname"))) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") + (exit 2)) + ((not (args:get-arg "-testpatt")) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (exit 3)) + (else + (if (not (car *configinfo*)) + (begin + (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (runs:operate-on action + target + (or (args:get-arg "-runname")(args:get-arg ":runname")) + (args:get-arg "-testpatt") + state: (or (args:get-arg "-state")(args:get-arg ":state") ) + status: (or (args:get-arg "-status")(args:get-arg ":status")) + new-state-status: (args:get-arg "-set-state-status"))) + (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (operate-on 'remove-runs)))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (operate-on 'set-state-status)))) + +(if (or (args:get-arg "-set-run-status") + (args:get-arg "-get-run-status")) + (general-run-call + "-set-run-status" + "set run status" + (lambda (target runname keys keyvals) + (let* ((runsdat (rmt:get-runs-by-patt keys runname + (common:args-get-target) + #f #f)) + (header (vector-ref runsdat 0)) + (rows (vector-ref runsdat 1))) + (if (null? rows) + (begin + (debug:print-info 0 "No matching run found.") + (exit 1)) + (let* ((row (car (vector-ref runsdat 1))) + (run-id (db:get-value-by-header row header "id"))) + (if (args:get-arg "-set-run-status") + (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) + (print (rmt:get-run-status run-id)) + ))))))) ;;====================================================================== ;; Query runs ;;====================================================================== +;; NOTE: list-runs and list-db-targets operate on local db!!! +;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) - (if (setup-for-run) - (let* ((db #f) + (if (launch:setup-for-run) + (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (cdb:remote-run db:get-runs #f runpatt #f #f '())) + (keys (db:get-keys dbstruct)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + #f #f)) + ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (cdb:remote-run db:get-keys #f)) - (keynames (map key:get-fieldname keys)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) - keynames) "/"))) + keys) "/"))) (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (cdb:remote-run db:get-tests-for-run #f run-id testpatt '() '()))) + (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) @@ -525,33 +772,36 @@ (db:test-get-status test) (db:test-get-run_duration test) (db:test-get-event_time test) (db:test-get-host test)) (if (not (or (equal? (db:test-get-status test) "PASS") - (equal? (db:test-get-status test) "WARN") + (equal? (db:test-get-status test) "WARN") (equal? (db:test-get-state test) "NOT_STARTED"))) (begin - (print " cpuload: " (db:test-get-cpuload test) + (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " (db:test-get-uname test) - "\n rundir: " (db:test-get-rundir test) + "\n uname: " ;; (sdb:qry 'getstr + (db:test-get-uname test) ;; ) + "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (db:get-steps-for-test #f (db:test-get-id test)))) + (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (db:step-get-stepname step) - (db:step-get-state step) - (db:step-get-status step) - (db:step-get-event_time step))) + (tdb:step-get-stepname step) + (tdb:step-get-state step) + (tdb:step-get-status step) + (tdb:step-get-event_time step))) steps))))) tests))))) runs) - (set! *didsomething* #t)))) + ;; (db:close-all dbstruct) + (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== @@ -572,14 +822,13 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:run-tests target runname - "%" (args:get-arg "-testpatt") user args:arg-hash)))) ;;====================================================================== @@ -601,48 +850,55 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) + ;; + ;; May or may not implement it this way ... + ;; + ;; Insert this run into the tasks queue + ;; (open-run-close tasks:add tasks:open-db + ;; "runtests" + ;; user + ;; target + ;; runname + ;; (args:get-arg "-runtests") + ;; #f)))) (runs:run-tests target runname (args:get-arg "-runtests") - (args:get-arg "-testpatt") user args:arg-hash)))) ;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") - (begin - (debug:print 0 "ERROR: Rollup is currently not working. If you need it please submit a ticket at http://www.kiatoa.com/fossils/megatest") - (exit 4))) -;; (general-run-call -;; "-rollup" -;; "rollup tests" -;; (lambda (target runname keys keynames keyvallst) -;; (runs:rollup-run keys -;; (keys->alist keys "na") -;; (args:get-arg ":runname") -;; user)))) + (general-run-call + "-rollup" + "rollup tests" + (lambda (target runname keys keyvals) + (runs:rollup-run keys + keyvals + (or (args:get-arg "-runname")(args:get-arg ":runname") ) + user)))) ;;====================================================================== ;; Lock or unlock a run ;;====================================================================== (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) (general-run-call (if (args:get-arg "-lock") "-lock" "-unlock") "lock/unlock tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:handle-locking target keys - (args:get-arg ":runname") + (or (args:get-arg "-runname")(args:get-arg ":runname") ) (args:get-arg "-lock") (args:get-arg "-unlock") user)))) ;;====================================================================== @@ -651,51 +907,45 @@ ;; Get test paths matching target, runname, and testpatt (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) - ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) - (let* ((keys (cdb:remote-run db:get-keys db)) - (keynames (map key:get-fieldname keys)) + (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -704,50 +954,43 @@ ;; Archive tests matching target, runname, and testpatt (if (args:get-arg "-archive") ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) - ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) - (let* ((keys (cdb:remote-run db:get-keys db)) - (keynames (map key:get-fieldname keys)) - ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target))) + (let* ((keys (rmt:get-keys)) + (paths (tests:test-get-paths-matching keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) - paths))) + paths)) + ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) + ) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" - (lambda (target runname keys keynames keyvallst) - (let* ((db #f) - ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target))) + (lambda (target runname keys keyvals) + (let* ((paths (tests:test-get-paths-matching keys target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -756,18 +999,20 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" - (lambda (target runname keys keynames keyvallst) - (let ((db #f) + (lambda (target runname keys keyvals) + (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) - (runspatt (args:get-arg ":runname")) - (pathmod (args:get-arg "-pathmod")) - (keyvalalist (keys->alist keys "%"))) - (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) - (cdb:remote-run db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) + (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (pathmod (args:get-arg "-pathmod"))) + ;; (keyvalalist (keys->alist keys "%"))) + (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) + (db:close-all dbstruct) + (set! *didsomething* #t))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -787,31 +1032,27 @@ (define (megatest:step step state status logfile msg) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) - (let* ((cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) - ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - ;; DO NOT remote run - (db:teststep-set-status! db test-id step state status msg logfile) + (rmt:teststep-set-status! run-id test-id step state status msg logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -824,10 +1065,12 @@ (args:get-arg "-m")) ;; (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous + ;; NEW POLICY - -setlog sets test overall log on every call. (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") (args:get-arg "-runstep") @@ -835,47 +1078,45 @@ (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) - (change-directory testpath) - ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) + (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) + (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (db:load-test-data db test-id)) + (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (cdb:test-set-log! *runremote* test-id logfname))) + (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote - (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) + (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote - (tests:summarize-items db run-id test-name #t)) ;; do force here + (tests:summarize-items run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) @@ -884,27 +1125,29 @@ (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) (cmd (if (null? remargs) #f (car remargs))) (params (if cmd (cdr remargs) '())) (exitstat #f) - (shell (last (string-split (get-environment-variable "SHELL") "/"))) + (shell (let ((sh (get-environment-variable "SHELL") )) + (if sh + (last (string-split sh "/")) + "bash"))) (redir (case (string->symbol shell) ((tcsh csh ksh) ">&") ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step - (debug:print-info 2 "Running \"" fullcmd "\"") + (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) - (set! exitstat (system fullcmd)) ;; cmd params)) + (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) - (change-directory testpath) + ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) @@ -911,14 +1154,13 @@ (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (cdb:test-set-log! *runremote* test-id htmllogfile))) + (rmt:test-set-log! run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile)) + (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) @@ -936,33 +1178,34 @@ (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) - ;; (sqlite3:finalize! db) + (if (sqlite3:database? db)(sqlite3:finalize! db)) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here - (tests:test-set-status! test-id state newstatus msg otherdata)))) - (if db (sqlite3:finalize! db)) + (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) + (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== -(if (args:get-arg "-showkeys") +(if (or (args:get-arg "-showkeys") + (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! keys (cbd:remote-run db:get-keys db)) - (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) - (if db (sqlite3:finalize! db)) + (set! keys (cdb:remote-run db:get-keys db)) + (debug:print 1 "Keys: " (string-intersperse keys ", ")) + (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") @@ -978,78 +1221,167 @@ (let ((testname (args:get-arg "-gen-megatest-test"))) (genexample:mk-megatest-test testname) (set! *didsomething* #t))) ;;====================================================================== -;; Update the database schema on request +;; Update the database schema, clean up the db ;;====================================================================== (if (args:get-arg "-rebuild-db") (begin - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) + +(if (args:get-arg "-cleanup-db") + (begin + (if (not (launch:setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + ;; keep this one local + ;; (open-run-close db:clean-up #f) + (db:multi-db-sync + #f ;; do all run-ids + ;; 'new2old + 'killservers + 'dejunk + ;; 'adj-testids + ;; 'old2new + 'new2old + ) + (set! *didsomething* #t))) + +(if (args:get-arg "-mark-incompletes") + (begin + (if (not (launch:setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") b + (exit 1))) + (open-run-close db:find-and-mark-incomplete #f) + (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== (if (args:get-arg "-update-meta") (begin - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local - (open-run-close runs:update-all-test_meta db) + (open-run-close runs:update-all-test_meta #f) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) - (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) - (if db + (let* ((toppath (launch:setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (if dbstruct (begin - (set! *db* db) + (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) - ;; (client:setup) - ;; (client:launch) (import readline) (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) - (load (args:get-arg "-load")))) + (load (args:get-arg "-load"))) + (db:close-all dbstruct)) (exit)) (set! *didsomething* #t))) + +;;====================================================================== +;; Wait on a run to complete +;;====================================================================== + +(if (and (args:get-arg "-run-wait") + (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now + (begin + (if (not (launch:setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (operate-on 'run-wait) + (set! *didsomething* #t))) + +;; ;; ;; redo me ;; Not converted to use dbstruct yet +;; ;; ;; redo me ;; +;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") +;; ;; ;; redo me (let* ((toppath (setup-for-run)) +;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) +;; ;; ;; redo me (for-each +;; ;; ;; redo me (lambda (field) +;; ;; ;; redo me (let ((dat '())) +;; ;; ;; redo me (debug:print-info 0 "Getting data for field " field) +;; ;; ;; redo me (sqlite3:for-each-row +;; ;; ;; redo me (lambda (id val) +;; ;; ;; redo me (set! dat (cons (list id val) dat))) +;; ;; ;; redo me (db:get-db db run-id) +;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) +;; ;; ;; redo me (debug:print-info 0 "found " (length dat) " items for field " field) +;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) +;; ;; ;; redo me (for-each +;; ;; ;; redo me (lambda (item) +;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid +;; ;; ;; redo me (cadr item))) ;; ) +;; ;; ;; redo me (if (not (equal? newval (cadr item))) +;; ;; ;; redo me (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) +;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) +;; ;; ;; redo me dat) +;; ;; ;; redo me (sqlite3:finalize! qry)))) +;; ;; ;; redo me (db:close-all dbstruct) +;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) +;; ;; ;; redo me (set! *didsomething* #t))) + +(if (args:get-arg "-import-megatest.db") + (begin + (db:multi-db-sync + #f ;; do all run-ids + 'killservers + 'dejunk + 'adj-testids + 'old2new + ;; 'new2old + ) + (set! *didsomething* #t))) + +(if (args:get-arg "-sync-to-megatest.db") + (begin + (db:multi-db-sync + #f ;; do all run-ids + 'new2old + ) + (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== -;; this is the socket if we are a client -;; (if (and *runremote* -;; (socket? *runremote*)) -;; (close-socket *runremote*)) +(if *runremote* (close-all-connections!)) (if (not *didsomething*) (debug:print 0 help)) -;; (if *runremote* (rpc:close-all-connections!)) - +(set! *time-to-exit* #t) +(thread-join! *watchdog*) + (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) ADDED minimal/megatest.config Index: minimal/megatest.config ================================================================== --- /dev/null +++ minimal/megatest.config @@ -0,0 +1,12 @@ +[fields] +RUNTYPE text + +[setup] +linktree #{getenv PWD}/linktree +max_concurrent_jobs 20 + +[jobtools] +launcher nbfake + +[disks] +disk0 #{getenv PWD}/runs ADDED minimal/runconfigs.config Index: minimal/runconfigs.config ================================================================== --- /dev/null +++ minimal/runconfigs.config @@ -0,0 +1,3 @@ +[default] +EXAMPLEVAR 1 + ADDED minimal/tests/tmpspace/testconfig Index: minimal/tests/tmpspace/testconfig ================================================================== --- /dev/null +++ minimal/tests/tmpspace/testconfig @@ -0,0 +1,27 @@ +[ezsteps] + +df [ `df -m /tmp | grep /tmp | awk '{print $3}'` -gt 200000 ] + +[items] +TARGETHOST chlr10722 \ + chlr15003 \ + chlr13406 \ + chlr12539 \ + chlr12713 \ + chlr11407 \ + chlr14713 \ + chlr11440 \ + chlr11417 \ + chlr14709 \ + chlr11722 \ + chlr11445 \ + chlr11421 \ + chlr11404 + +[test_meta] +author mrwellan +owner mrwellan +description Check for available space in /tmp +tags Utility +reviewed ww50.3 + ADDED mt.scm Index: mt.scm ================================================================== --- /dev/null +++ mt.scm @@ -0,0 +1,217 @@ +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit mt)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(declare (uses tests)) +(declare (uses server)) +(declare (uses runs)) +(declare (uses rmt)) +;; (declare (uses filedb)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; This is the Megatest API. All generally "useful" routines will be wrapped or extended +;; here. + +;;====================================================================== +;; R U N S +;;====================================================================== + +;; runs:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; to extract info from the structure returned +;; +(define (mt:get-runs-by-patt keys runnamepatt targpatt) + (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) + (res '()) + (offset 0) + (limit 500)) + ;; (print "runsdat: " runsdat) + (let* ((header (vector-ref runsdat 0)) + (runslst (vector-ref runsdat 1)) + (full-list (append res runslst)) + (have-more (eq? (length runslst) limit))) + ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) + (if have-more + (let ((new-offset (+ offset limit)) + (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit))) + (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") + (debug:print-info 0 "next-batch: " next-batch) + (loop next-batch + full-list + new-offset + limit)) + (vector header full-list))))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) + (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals)) + (res '()) + (offset 0) + (limit 500)) + (let* ((full-list (append res testsdat)) + (have-more (eq? (length testsdat) limit))) + (if have-more + (let ((new-offset (+ offset limit))) + (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") + (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals) + full-list + new-offset + limit)) + full-list)))) + +(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) ) + (let* ((key (list run-id waitons ref-item-path mode)) + (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) + (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (if last-time + (< (current-seconds)(+ last-time 5)) + #f)))) + (if useres + (let ((result (vector-ref res 1))) + (debug:print 4 "Using lazy value res: " result) + result) + (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) +;; (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) + (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) + newres)))) + +(define (mt:get-run-stats dbstruct run-id) +;; Get run stats from local access, move this ... but where? + (db:get-run-stats dbstruct run-id)) + +(define (mt:discard-blocked-tests run-id failed-test tests test-records) + (if (null? tests) + tests + (begin + (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (let loop ((testn (car tests)) + (remt (cdr tests)) + (res '())) + (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) + (waitons (vector-ref test-dat 2))) + ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) + (if (null? remt) + (let ((new-res (reverse res))) + ;; (print " new-res: " new-res) + new-res) + (loop (car remt) + (cdr remt) + (if (member failed-test waitons) + (begin + (debug:print 0 "Discarding test " testn "(" test-dat ") due to " failed-test) + res) + (cons testn res))))))))) + +;;====================================================================== +;; T R I G G E R S +;;====================================================================== + +(define (mt:process-triggers run-id test-id newstate newstatus) + (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) + (test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test-dat)) ;; ) ;; ) + (test-name (db:test-get-testname test-dat)) + (tconfig #f) + (state (if newstate newstate (db:test-get-state test-dat))) + (status (if newstatus newstatus (db:test-get-status test-dat)))) + (if (and test-rundir ;; #f means no dir set yet + (file-exists? test-rundir) + (directory? test-rundir)) + (begin + (push-directory test-rundir) + (set! tconfig (mt:lazy-read-test-config test-name)) + (pop-directory) + (for-each (lambda (trigger) + (let ((cmd (configf:lookup tconfig "triggers" trigger)) + (logf (conc test-rundir "/last-trigger.log"))) + (if cmd + ;; Putting the commandline into ( )'s means no control over the shell. + ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files + ;; or equivalent. No need to do this. Just run it? + (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&"))) + (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd) + (process-run fullcmd))))) + (list + (conc state "/" status) + (conc state "/") + (conc "/" status))))))) + +;;====================================================================== +;; S T A T E A N D S T A T U S F O R T E S T S +;;====================================================================== + +;; speed up for common cases with a little logic +(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (if (not (and run-id test-id)) + (begin + (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) + (print-call-chain (current-error-port)) + #f) + (begin + (cond + ((and newstate newstatus newcomment) + (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) + ((and newstate newstatus) + (rmt:general-call 'state-status run-id newstate newstatus test-id)) + (else + (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) + (mt:process-triggers run-id test-id newstate newstatus) + #t))) + +(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) + (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) + (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) + +(define (mt:lazy-read-test-config test-name) + (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) + (if tconf + tconf + (let ((test-dirs (tests:get-tests-search-path *configdat*))) + (let loop ((hed (car test-dirs)) + (tal (cdr test-dirs))) + ;; Setting MT_LINKTREE here is almost certainly unnecessary. + (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) + (if (and (file-exists? tconfig-file) + (file-read-access? tconfig-file)) + (let ((link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (old-link-tree (get-environment-variable "MT_LINKTREE"))) + (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) + (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] + (hash-table-set! *testconfigs* test-name newtcfg) + (if old-link-tree + (setenv "MT_LINKTREE" old-link-tree) + (unsetenv "MT_LINKTREE")) + newtcfg)) + (if (null? tal) + (begin + (debug:print 0 "ERROR: No readable testconfig found for " test-name) + #f) + (loop (car tal)(cdr tal)))))))))) + Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -1,17 +1,17 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use format) +(use format numbers) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) @@ -22,10 +22,12 @@ (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) (declare (uses server)) (declare (uses synchash)) +(declare (uses dcommon)) +(declare (uses tree)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") @@ -65,59 +67,35 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (setup-for-run)) +(if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(if (args:get-arg "-host") - (begin - (set! *runremote* (string-split (args:get-arg "-host" ":"))) - (client:launch)) - (client:launch)) +;; (if (args:get-arg "-host") +;; (begin +;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (client:launch)) + + +(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* + local: #t)) +(define *db-file-path* (db:dbfile-path 0)) +;; HACK ALERT: this is a hack, please fix. +(define *read-only* (not (file-read-access? *db-file-path*))) (debug:setup) (define *tim* (iup:timer)) (define *ord* #f) -(define *data* (make-vector 10 #f)) -(define-inline (dboard:data-get-runs vec) (vector-ref vec 0)) -(define-inline (dboard:data-get-tests vec) (vector-ref vec 1)) -(define-inline (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) -(define-inline (dboard:data-get-tests-tree vec) (vector-ref vec 3)) -(define-inline (dboard:data-get-run-keys vec) (vector-ref vec 4)) -(define-inline (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) -;; (define-inline (dboard:data-get-test-details vec) (vector-ref vec 6)) -(define-inline (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) -(define-inline (dboard:data-get-updaters vec) (vector-ref vec 8)) - -(define-inline (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) -(define-inline (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) -(define-inline (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) -(define-inline (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) -(define-inline (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) -(define-inline (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) -;; (define-inline (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) -(define-inline (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) -(define-inline (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) - -(dboard:data-set-run-keys! *data* (make-hash-table)) - -;; List of test ids being viewed in various panels -(dboard:data-set-curr-test-ids! *data* (make-hash-table)) - -;; Look up test-ids by (key1 key2 ... testname [itempath]) -(dboard:data-set-path-test-ids! *data* (make-hash-table)) - -;; Each test panel has an updater, only call when the tab is exposed -(dboard:data-set-updaters! *data* (make-hash-table)) - (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") (define (message-window msg) (iup:show @@ -145,49 +123,17 @@ (string-intersperse (map conc x) ",")) (define (update-search x val) (hash-table-set! *searchpatts* x val)) -(define (main-menu) - (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) - (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (iup:show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) - (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) - ;; mtest is actually the megatest.config file ;; (define (mtest window-id) (let* ((curr-row-num 0) (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) - (keys-matrix (iup:matrix - #:expand "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 5 - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status)))) - (setup-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 3)) + (keys-matrix (dcommon:keys-matrix rawconfig)) + (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) (jobtools-matrix (iup:matrix #:expand "YES" #:numcol 1 #:numlin 5 #:numcol-visible 1 @@ -209,28 +155,17 @@ #:numcol 1 #:numlin 20 #:numcol-visible 1 #:numlin-visible 8)) ) - (iup:attribute-set! keys-matrix "0:0" "Field Num") - (iup:attribute-set! keys-matrix "0:1" "Field Name") - (iup:attribute-set! keys-matrix "WIDTH1" "100") (iup:attribute-set! disks-matrix "0:0" "Disk Name") (iup:attribute-set! disks-matrix "0:1" "Disk Path") (iup:attribute-set! disks-matrix "WIDTH1" "120") (iup:attribute-set! disks-matrix "WIDTH0" "100") (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") - ;; fill in keys - (set! curr-row-num 1) - (for-each - (lambda (var) - (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) - (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) - (configf:section-vars rawconfig "fields")) ;; fill in existing info (for-each (lambda (mat fname) (set! curr-row-num 1) @@ -316,108 +251,10 @@ ;; (define (rconfig window-id) (iup:vbox (iup:frame #:title "Default"))) -;;====================================================================== -;; T R E E S T U F F -;;====================================================================== - -;; path is a list of nodes, each the child of the previous -;; this routine returns the id so another node can be added -;; either as a leaf or as a branch -;; -;; BUG: This needs a stop sensor for when a branch is exhausted -;; -(define (tree-find-node obj path) - ;; start at the base of the tree - (if (null? path) - #f ;; or 0 ???? - (let loop ((hed (car path)) - (tal (cdr path)) - (depth 0) - (nodenum 0)) - ;; nodes in iup tree are 100% sequential so iterate over nodenum - (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes - (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) - (node-title (iup:attribute obj (conc "TITLE" nodenum)))) - (if (and (equal? depth node-depth) - (equal? hed node-title)) ;; yep, this is the one! - (if (null? tal) ;; end of the line - nodenum - (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) - ;; this is the case where we found part of the hierarchy but not - ;; all of it, i.e. the node-depth went from deep to less deep - (if (> depth node-depth) ;; (+ 1 node-depth)) - #f - (loop hed tal depth (+ nodenum 1))))) - #f)))) - -;; top is the top node name zeroeth node VALUE=0 -(define (tree-add-node obj top nodelst #!key (userdata #f)) - (if (not (iup:attribute obj "TITLE0")) - (iup:attribute-set! obj "ADDBRANCH0" top)) - (cond - ((not (string=? top (iup:attribute obj "TITLE0"))) - (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) - ((null? nodelst)) - (else - (let loop ((hed (car nodelst)) - (tal (cdr nodelst)) - (depth 1) - (pathl (list top))) - ;; Because the tree dialog changes node numbers when - ;; nodes are added or removed we must look up nodes - ;; each and every time. 0 is the top node so default - ;; to that. - (let* ((newpath (append pathl (list hed))) - (parentnode (tree-find-node obj pathl)) - (nodenum (tree-find-node obj newpath))) - ;; Add the branch under lastnode if not found - (if (not nodenum) - (begin - (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) - (if userdata - (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) - (if (null? tal) - #t - ;; reset to top - (loop (car nodelst)(cdr nodelst) 1 (list top)))) - (if (null? tal) ;; if null here then this path has already been added - #t - (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) - -(define (tree-node->path obj nodenum) - ;; (print "\ncurrnode nodenum depth node-depth node-title path") - (let loop ((currnode 0) - (depth 0) - (path '())) - (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode))) - (node-title (iup:attribute obj (conc "TITLE" currnode)))) - ;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path)) - (if (> currnode nodenum) - path - (if (not node-depth) ;; #f if we are out of nodes - '() - (let ((ndepth (string->number node-depth))) - (if (eq? ndepth depth) - ;; This next is the match condition depth == node-depth - (if (eq? currnode nodenum) - (begin - ;; (display " ") - (append path (list node-title))) - (loop (+ currnode 1) - (+ depth 1) - (append path (list node-title)))) - ;; didn't match, reset to base path and keep looking - ;; due to more iup odditys we don't reset to base - (begin - ;; (display " ") - (loop (+ 1 currnode) - 2 - (append (take path ndepth)(list node-title))))))))))) - ;;====================================================================== ;; T E S T S ;;====================================================================== (define (tree-path->test-id path) @@ -438,14 +275,17 @@ (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) - (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) - (command-launch-button (iup:button "Execute!" #:action (lambda (x) - (let ((cmd (iup:attribute command-text-box "VALUE"))) - (system (conc cmd " &")))))) + (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) + (command-launch-button (iup:button "Execute!" + ;; #:expand "HORIZONTAL" + #:size "50x" + #:action (lambda (x) + (let ((cmd (iup:attribute command-text-box "VALUE"))) + (system (conc cmd " &")))))) (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") @@ -487,13 +327,13 @@ #:numlin 5 #:numcol-visible 1 #:numlin-visible 5)) (steps-matrix (iup:matrix #:expand "YES" - #:numcol 5 + #:numcol 6 #:numlin 50 - #:numcol-visible 5 + #:numcol-visible 6 #:numlin-visible 8)) (data-matrix (iup:matrix #:expand "YES" #:numcol 8 #:numlin 50 @@ -518,15 +358,18 @@ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) ;; Steps matrix (iup:attribute-set! steps-matrix "0:1" "Step Name") (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "WIDTH2" "40") (iup:attribute-set! steps-matrix "0:3" "End") - (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "WIDTH3" "40") (iup:attribute-set! steps-matrix "0:4" "Status") - (iup:attribute-set! steps-matrix "WIDTH4" "50") - (iup:attribute-set! steps-matrix "0:5" "Log File") + (iup:attribute-set! steps-matrix "WIDTH4" "40") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "WIDTH5" "40") + (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") @@ -557,48 +400,56 @@ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) - (iup:vbox - (iup:hbox - run-info-matrix - test-info-matrix) - (iup:hbox - test-run-matrix - meta-dat-matrix) - (iup:vbox - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x")) - (apply - iup:hbox - (list command-text-box command-launch-button)))) - (iup:vbox - (let ((tabs (iup:tabs - steps-matrix - data-matrix))) - (iup:attribute-set! tabs "TABTITLE0" "Test Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs))))) + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + (iup:hbox + (iup:vbox + run-info-matrix + test-info-matrix) + ;; test-info-matrix) + (iup:vbox + test-run-matrix + meta-dat-matrix)) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" + (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" + (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" + (iup:hbox + ;; hiup:split ;; hbox + ;; #:orientation "HORIZONTAL" + ;; #:value 300 + command-text-box + command-launch-button))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) ;; Test browser (define (tests window-id) - (iup:hbox + (iup:split (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree-node->path obj id)) + (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) (if test-id (hash-table-set! (dboard:data-get-curr-test-ids *data*) window-id test-id)) - (print "path: " (tree-node->path obj id) " test-id: " test-id)))))) + (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) (iup:attribute-set! tb "VALUE" "0") (iup:attribute-set! tb "NAME" "Runs") ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") (dboard:data-set-tests-tree! *data* tb) tb) @@ -609,14 +460,18 @@ ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) + (run-id (db:test-get-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) - (db:test-get-run_id test-data) '())) + run-id + '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) - (runname (if (null? targ/runname) "" (car (cdr targ/runname))))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) + (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id))) + (if test-data (begin ;; (for-each (lambda (data) @@ -657,14 +512,15 @@ (db:test-get-uname test-data) (db:test-get-diskfree test-data) (db:test-get-cpuload test-data) (seconds->hr-min-sec (db:test-get-run_duration test-data))) (make-list 5 ""))) + )) + (dcommon:populate-steps steps-dat steps-matrix)))))) ;;(list meta-dat-matrix ;; (if test-id ;; (list ( - ))))))) ;; db:test-get-id ;; db:test-get-run_id ;; db:test-get-testname @@ -714,172 +570,20 @@ ;; Browse and control a single run ;; (define (runcontrol window-id) (iup:hbox)) -;;====================================================================== -;; P R O C E S S R U N S -;;====================================================================== - -;; MOVE THIS INTO *data* -(define *cachedata* (make-hash-table)) -(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) -(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) - -;; TO-DO -;; 1. Make "data" hash-table hierarchial store of all displayed data -;; 2. Update synchash to understand "get-runs", "get-tests" etc. -;; 3. Add extraction of filters to synchash calls -;; -;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (run-update keys data runname keypatts testpatt states statuses mode window-id) - (let* (;; count and offset => #f so not used - ;; the synchash calls modify the "data" hash - (get-runs-sig (conc (client:get-signature) " get-runs")) - (get-tests-sig (conc (client:get-signature) " get-tests")) - (get-details-sig (conc (client:get-signature) " get-test-details")) - - ;; test-ids to get and display are indexed on window-id in curr-test-ids hash - (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) - - (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) - (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids) - '())) - - ;; Now can calculate the run-ids - (run-hash (hash-table-ref/default data get-runs-sig #f)) - (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - - (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses)) - (runs-hash (hash-table-ref/default data get-runs-sig #f)) - (header (hash-table-ref/default runs-hash "header" #f)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a header "event_time")) - (time-b (db:get-value-by-header record-b header "event_time"))) - (> time-a time-b))) - )) - (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) - (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) - (colnum 1) - (rownum 0)) ;; rownum = 0 is the header -;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) - - ;; tests related stuff - ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) - - ;; Given a run-id and testname/item_path calculate a cell R:C - - ;; NOTE: Also build the test tree browser and look up table - ;; - ;; Each run is unique on its keys and runname or run-id, store in hash on colnum - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) - (map key:get-fieldname keys))) - (run-name (db:get-value-by-header run-record header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" colnum) col-name) - (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (set! colnum (+ colnum 1)))) - run-ids) - - ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table - ;; Do this analysis in the order of the run-ids, the most recent run wins - (for-each (lambda (run-id) - (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) - (new-test-dat (car test-changes)) - (removed-tests (cadr test-changes)) - (tests (sort (map cadr (filter (lambda (testrec) - (eq? run-id (db:mintest-get-run_id (cadr testrec)))) - new-test-dat)) - (lambda (a b) - (let ((time-a (db:mintest-get-event_time a)) - (time-b (db:mintest-get-event_time b))) - (> time-a time-b))))) - ;; test-changes is a list of (( id record ) ... ) - ;; Get list of test names sorted by time, remove tests - (test-names (delete-duplicates (map (lambda (t) - (let ((i (db:mintest-get-item_path t)) - (n (db:mintest-get-testname t))) - (if (string=? i "") - (conc " " i) - n))) - tests))) - (colnum (car (hash-table-ref runid-to-col run-id)))) - ;; for each test name get the slot if it exists and fill in the cell - ;; or take the next slot and fill in the cell, deal with items in the - ;; run view panel? The run view panel can have a tree selector for - ;; browsing the tests/items - - ;; SWITCH THIS TO USING CHANGED TESTS ONLY - (for-each (lambda (test) - (let* ((test-id (db:mintest-get-id test)) - (state (db:mintest-get-state test)) - (status (db:mintest-get-status test)) - (testname (db:mintest-get-testname test)) - (itempath (db:mintest-get-item_path test)) - (fullname (conc testname "/" itempath)) - (dispname (if (string=? itempath "") testname (conc " " itempath))) - (rownum (hash-table-ref/default testname-to-row fullname #f)) - (test-path (append run-path (if (equal? itempath "") - (list testname) - (list testname itempath))))) - (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" - test-path - userdata: (conc "test-id: " test-id)) - (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) - (if (not rownum) - (let ((rownums (hash-table-values testname-to-row))) - (set! rownum (if (null? rownums) - 1 - (+ 1 (apply max rownums)))) - (hash-table-set! testname-to-row fullname rownum) - ;; create the label - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" 0) dispname) - )) - ;; set the cell text and color - ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" colnum) - (if (string=? state "COMPLETED") - status - state)) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc "BGCOLOR" rownum ":" colnum) - (gutils:get-color-for-state-status state status)) - )) - tests))) - run-ids) - - (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) - (if updater (updater (hash-table-ref/default data get-details-sig #f)))) - - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") - ;; (debug:print 2 "run-changes: " run-changes) - ;; (debug:print 2 "test-changes: " test-changes) - (list run-changes test-changes))) - ;;====================================================================== ;; D A S H B O A R D ;;====================================================================== ;; Main Panel (define (main-panel window-id) (iup:dialog #:title "Megatest Control Panel" - #:menu (main-menu) + #:menu (dcommon:main-menu) + #:shrink "YES" (let ((tabtop (iup:tabs (runs window-id) (tests window-id) (runcontrol window-id) (mtest window-id) @@ -892,16 +596,16 @@ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) -(define (newdashboard) +(define (newdashboard dbstruct) (let* ((data (make-hash-table)) - (keys (cdb:remote-run db:get-keys #f)) + (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") - (keypatts (map (lambda (k)(list (vector-ref k 0) "%")) keys)) + (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) @@ -914,13 +618,14 @@ (lambda (x) ;; Want to dedicate no more than 50% of the time to this so skip if ;; 2x delta time has not passed since last query (if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) - (changes (run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) + (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) (debug:print 11 "CHANGE(S): " (car changes) "...")) (debug:print-info 11 "Server overloaded")))))) -(newdashboard) +(dboard:data-set-updaters! *data* (make-hash-table)) +(newdashboard *dbstruct-local*) (iup:main-loop) ADDED oldsrc/fs-transport.scm Index: oldsrc/fs-transport.scm ================================================================== --- /dev/null +++ oldsrc/fs-transport.scm @@ -0,0 +1,44 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(import (prefix sqlite3 sqlite3:)) + +(use spiffy uri-common intarweb http-client spiffy-request-vars) + +(tcp-buffer-size 2048) + +(declare (unit fs-transport)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tests)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. + +(include "common_records.scm") +(include "db_records.scm") + + +;;====================================================================== +;; F S T R A N S P O R T S E R V E R +;;====================================================================== + +;; There is no "server" per se but a convience routine to make it non +;; necessary to be reopening the db over and over again. +;; + +(define (fs:process-queue-item packet) + (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called + (set! *megatest-db* (open-db))) + (debug:print-info 11 "fs:process-queue-item called with packet=" packet) + (db:process-queue-item *megatest-db* packet)) + ADDED oldsrc/zmq-transport.scm Index: oldsrc/zmq-transport.scm ================================================================== --- /dev/null +++ oldsrc/zmq-transport.scm @@ -0,0 +1,494 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(import (prefix sqlite3 sqlite3:)) + +(use zmq) + +(declare (unit zmq-transport)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tests)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses server)) + +(include "common_records.scm") +(include "db_records.scm") + +;; Transition to pub --> sub with pull <-- push +;; +;; 1. client sends request to server via push to the pull port +;; 2. server puts request in queue or processes immediately as appropriate +;; 3. server puts responses from completed requests into pub port +;; +;; TODO +;; +;; Done Tested +;; [x] [ ] 1. Add columns pullport pubport to servers table +;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 +;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports +;; [x] [ ] 4. Add client compose of request +;; [x] [ ] - name of client: testname/itempath-test_id-hostname +;; [x] [ ] - name of request: callname, params +;; [x] [ ] - request key: f(clientname, callname, params) +;; [x] [ ] 5. Add processing of subscription hits +;; [x] [ ] - done when get key +;; [x] [ ] - return results +;; [x] [ ] 6. Add timeout processing +;; [x] [ ] - after 60 seconds +;; [ ] [ ] i. check server alive, connect to new if necessary +;; [ ] [ ] ii. resend request +;; [ ] [ ] 7. Turn self ping back on + +(define (zmq-transport:make-server-url hostport) + (if (not hostport) + #f + (conc "tcp://" (car hostport) ":" (cadr hostport)))) + +(define *server-loop-heart-beat* (current-seconds)) +(define *heartbeat-mutex* (make-mutex)) + +;;====================================================================== +;; S E R V E R +;;====================================================================== + +(define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) +(define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) +(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) +(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) + +(define (zmq-transport:run hostn) + (debug:print 2 "Attempting to start the server ...") + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") + (exit)))) + (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db + (zmq-sdat1 #f) + (zmq-sdat2 #f) + (pull-socket #f) + (pub-socket #f) + (p1 #f) + (p2 #f) + (zmq-sockets-dat #f) + (iface (if (string=? "-" hostn) + "*" ;; (get-host-name) + hostn)) + (hostname (get-host-name)) + (ipaddrstr (let ((ipstr (if (string=? "-" hostn) + (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + #f))) + (if ipstr ipstr hostname))) + (last-run 0)) + (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port") + (string->number (args:get-arg "-port")) + (+ 5000 (random 1001))))) + + (set! zmq-sdat1 (car zmq-sockets-dat)) + (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port) + (set! p1 (caddr zmq-sdat1)) + + (set! zmq-sdat2 (cadr zmq-sockets-dat)) + (set! pub-socket (cadr zmq-sdat2)) + (set! p2 (caddr zmq-sdat2)) + + (set! *cache-on* #t) + + (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? + + ;; what to do when we quit + ;; +;; (on-exit (lambda () +;; (if (and *toppath* *server-info*) +;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) +;; (let loop () +;; (let ((queue-len 0)) +;; (thread-sleep! (random 5)) +;; (mutex-lock! *incoming-mutex*) +;; (set! queue-len (length *incoming-data*)) +;; (mutex-unlock! *incoming-mutex*) +;; (if (> queue-len 0) +;; (begin +;; (debug:print-info 0 "Queue not flushed, waiting ...") +;; (loop)))))))) + + ;; The heavy lifting + ;; + ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime + ;; + (debug:print-info 11 "Server setup complete, start listening for messages") + (let loop ((queue-lst '())) + (let* ((rawmsg (receive-message* pull-socket)) + (packet (db:string->obj rawmsg)) + (qtype (cdb:packet-get-qtype packet))) + (debug:print-info 12 "server=> received packet=" packet) + (if (not (member qtype '(sync ping))) + (begin + (mutex-lock! *heartbeat-mutex*) + (set! *last-db-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*))) + (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue + (begin + (db:process-queue-item db packet) + ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) + + (loop '())) + (loop (cons packet queue-lst))))))) + +;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being +;; used and to shutdown after sometime if it is not. +;; +(define (zmq-transport:keep-running) + ;; if none running or if > 20 seconds since + ;; server last used then start shutdown + ;; This thread waits for the server to come alive + (let* ((server-info (let loop () + (let ((sdat #f)) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *server-info*) + (mutex-unlock! *heartbeat-mutex*) + (if sdat sdat + (begin + (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again") + (sleep 4) + (loop)))))) + (iface (cadr server-info)) + (pullport (caddr server-info)) + (pubport (cadddr server-info)) ;; id interface pullport pubport) + ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport)) + (last-access 0)) + (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport) + (let loop ((count 0)) + (thread-sleep! 4) ;; no need to do this very often + ;; NB// sync currently does NOT return queue-length + ;; GET REAL QUEUE LENGTH FROM THE VARIABLE + (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1))) + ;; (print "Server running, count is " count) + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1))) + + ;; NOTE: Get rid of this mechanism! It really is not needed... + (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info)) + + ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + (if (> (+ last-access + ;; (* 50 60 60) ;; 48 hrs + ;; 60 ;; one minute + ;; (* 60 60) ;; one hour + (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. + ) + (current-seconds)) + (begin + (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (loop 0)) + (begin + (debug:print-info 0 "Starting to shutdown the server.") + ;; need to delete only *my* server entry (future use) + (set! *time-to-exit* #t) + (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) + (thread-sleep! 1) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Server shutdown complete. Exiting") + (exit))))))) + +(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50)) + (let ((s (if s s (make-socket stype))) + (p (if (number? port) port 5555)) + (old-handler (current-exception-handler))) + (handle-exceptions + exn + (begin + (debug:print 0 "Failed to bind to port " p ", trying next port") + (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) + ;; (old-handler) + ;; (print-call-chain) + (if (> trynum 0) + (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1)) + (debug:print-info 0 "Tried ports up to " p + " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")) + (exit)) ;; To exit or not? That is the question. + (let ((zmq-url (conc "tcp://" iface ":" p))) + (debug:print 2 "Trying to start server on " zmq-url) + (bind-socket s zmq-url) + (list iface s port))))) + +(define (zmq-transport:setup-ports ipaddrstr startport) + (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull)) + (p1 (caddr s1)) + (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub)) + (p2 (caddr s2))) + (set! *runremote* #f) + (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2) + (mutex-lock! *heartbeat-mutex*) + (set! *server-info* (open-run-close tasks:server-register + tasks:open-db + (current-process-id) + ipaddrstr p1 + 0 + 'live + 'zmq + pubport: p2)) + (debug:print-info 11 "*server-info* set to " *server-info*) + (mutex-unlock! *heartbeat-mutex*) + (list s1 s2))) + +(define (zmq-transport:mk-signature) + (message-digest-string (md5-primitive) + (with-output-to-string + (lambda () + (write (list (current-directory) + (argv))))))) + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +;; +(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '())) + (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions) + (let ((connect-ok #f) + (zmq-socket (if context + (make-socket type context) + (make-socket type))) + (conurl (zmq-transport:make-server-url (list iface port)))) + (if (socket? zmq-socket) + (begin + ;; first apply subscriptions + (for-each (lambda (subscription) + (debug:print 2 "Subscribing to " subscription) + (socket-option-set! zmq-socket 'subscribe subscription)) + subscriptions) + (connect-socket zmq-socket conurl) + zmq-socket) + (begin + (debug:print 0 "ERROR: Failed to open socket to " conurl) + #f)))) + +(define (zmq-transport:client-connect iface pullport pubport) + (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push)) + (sub-socket (zmq-transport:client-socket-connect iface pubport + type: 'sub + subscriptions: (list (client:get-signature) "all"))) + (zmq-sockets (vector push-socket sub-socket)) + (login-res #f)) + (debug:print-info 11 "zmq-transport:client-connect started. Next is login") + (set! login-res (client:login serverdat zmq-sockets)) + (if (and (not (null? login-res)) + (car login-res)) + (begin + (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".") + (set! *runremote* zmq-sockets) + zmq-sockets) + (begin + (debug:print-info 2 "Failed to login or connect to " conurl) + (set! *runremote* #f) + #f)))) + +;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being +;; used and to shutdown after sometime if it is not. +;; +(define (zmq-transport:keep-running) + ;; if none running or if > 20 seconds since + ;; server last used then start shutdown + ;; This thread waits for the server to come alive + (let* ((server-info (let loop () + (let ((sdat #f)) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *runremote*) + (mutex-unlock! *heartbeat-mutex*) + (if sdat sdat + (begin + (sleep 4) + (loop)))))) + (iface (car server-info)) + (port (cadr server-info)) + (last-access 0) + (tdb (tasks:open-db)) + (spid (tasks:server-get-server-id tdb #f iface port #f))) + (print "Keep-running got server pid " spid ", using iface " iface " and port " port) + (let loop ((count 0)) + (thread-sleep! 4) ;; no need to do this very often + ;; NB// sync currently does NOT return queue-length + (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) + ;; (print "Server running, count is " count) + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1))) + + ;; NOTE: Get rid of this mechanism! It really is not needed... + (tasks:server-update-heartbeat tdb spid) + + ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + (if (> (+ last-access + ;; (* 50 60 60) ;; 48 hrs + ;; 60 ;; one minute + ;; (* 60 60) ;; one hour + (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. + ) + (current-seconds)) + (begin + (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (loop 0)) + (begin + (debug:print-info 0 "Starting to shutdown the server.") + ;; need to delete only *my* server entry (future use) + (set! *time-to-exit* #t) + (tasks:server-deregister-self tdb (get-host-name)) + (thread-sleep! 1) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Server shutdown complete. Exiting") + (exit))))))) + +;; all routes though here end in exit ... +(define (zmq-transport:launch) + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: cannot find megatest.config, exiting") + (exit)))) + (debug:print-info 2 "Starting zmq server") + (if *toppath* + (let* (;; (th1 (make-thread (lambda () + ;; (let ((server-info #f)) + ;; ;; wait for the server to be online and available + ;; (let loop () + ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat") + ;; (thread-sleep! 2) + ;; (mutex-lock! *heartbeat-mutex*) + ;; (set! server-info *server-info* ) + ;; (mutex-unlock! *heartbeat-mutex*) + ;; (if (not server-info)(loop))) + ;; (debug:print 2 "Server alive, starting self-ping") + ;; (zmq-transport:self-ping server-info) + ;; )) + ;; "Self ping")) + (th2 (make-thread (lambda () + (zmq-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-"))) "Server run")) + ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) + ) + (set! *client-non-blocking-mode* #t) + ;; (thread-start! th1) + (thread-start! th2) + ;; (thread-start! th3) + (set! *didsomething* #t) + ;; (thread-join! th3) + (thread-join! th2) + ) + (debug:print 0 "ERROR: Failed to setup for megatest"))) + +(define (zmq-transport:client-signal-handler signum) + (handle-exceptions + exn + (debug:print " ... exiting ...") + (let ((th1 (make-thread (lambda () + (if (not *received-response*) + (receive-message* *runremote*))) ;; flush out last call if applicable + "eat response")) + (th2 (make-thread (lambda () + (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (thread-sleep! 3) ;; give the flush three seconds to do it's stuff + (debug:print 0 " Done.") + (exit 4)) + "exit on ^C timer"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) + +(define (zmq-transport:client-launch) + (set-signal-handler! signal/int zmq-transport:client-signal-handler) + (if (zmq-transport:client-setup) + (debug:print-info 2 "connected as client") + (begin + (debug:print 0 "ERROR: Failed to connect as client") + (exit)))) + +;;====================================================================== +;; Defunct functions +;;====================================================================== + +;; ping a server and return number of clients or #f (if no response) +;; NOT IN USE! +(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f)) + (cdb:use-non-blocking-mode + (lambda () + (let* ((res #f) + (th1 (make-thread + (lambda () + (let* ((zmq-context (make-context 1)) + (zmq-socket (zmq-transport:client-connect host port context: zmq-context))) + (if zmq-socket + (if (zmq-transport:client-login zmq-socket) + (let ((numclients (cdb:num-clients zmq-socket))) + (if (not return-socket) + (begin + (zmq-transport:client-logout zmq-socket) + (close-socket zmq-socket))) + (set! res (list #t numclients (if return-socket zmq-socket #f)))) + (begin + ;; (close-socket zmq-socket) + (set! res (list #f "CAN'T LOGIN" #f)))) + (set! res (list #f "CAN'T CONNECT" #f))))) + "Ping: th1")) + (th2 (make-thread + (lambda () + (let loop ((count 1)) + (debug:print-info 1 "Ping " count " server on " host " at port " port) + (thread-sleep! 2) + (if (< count (/ secs 2)) + (loop (+ count 1)))) + ;; (thread-terminate! th1) + (set! res (list #f "TIMED OUT" #f))) + "Ping: th2"))) + (thread-start! th2) + (thread-start! th1) + (handle-exceptions + exn + (set! res (list #f "TIMED OUT" #f)) + (thread-join! th1 secs)) + res)))) + +;; (define (zmq-transport:self-ping server-info) +;; ;; server-info: server-id interface pullport pubport +;; (let ((iface (list-ref server-info 1)) +;; (pullport (list-ref server-info 2)) +;; (pubport (list-ref server-info 3))) +;; (zmq-transport:client-connect iface pullport pubport) +;; (let loop () +;; (thread-sleep! 2) +;; (cdb:client-call *runremote* 'ping #t) +;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!") +;; (mutex-lock! *heartbeat-mutex*) +;; (set! *server-loop-heart-beat* (current-seconds)) +;; (mutex-unlock! *heartbeat-mutex*) +;; (loop)))) + +(define (zmq-transport:reply pubsock target query-sig success/fail result) + (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result) + (send-message pubsock target send-more: #t) + (send-message pubsock (db:obj->string (vector success/fail query-sig result)))) + ADDED portlogger.scm Index: portlogger.scm ================================================================== --- /dev/null +++ portlogger.scm @@ -0,0 +1,178 @@ + +;; Copyright 2006-2014, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit portlogger)) +(declare (uses db)) + +;; lsof -i + + +(define (portlogger:open-db fname) + (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away + (exists (file-exists? fname)) + (db (if avail + (sqlite3:open-database fname) + (begin + (system (conc "rm -f " fname)) + (sqlite3:open-database fname)))) + (handler (make-busy-timeout 136000)) + (canwrite (file-write-access? fname))) + ;; (db-init (lambda () + ;; (sqlite3:execute + ;; db + ;; "CREATE TABLE IF NOT EXISTS ports ( + ;; port INTEGER PRIMARY KEY, + ;; state TEXT DEFAULT 'not-used', + ;; fail_count INTEGER DEFAULT 0, + ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) + (sqlite3:set-busy-handler! db handler) + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (if (not exists) ;; needed with IF NOT EXISTS? + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS ports ( + port INTEGER PRIMARY KEY, + state TEXT DEFAULT 'not-used', + fail_count INTEGER DEFAULT 0, + update_time TIMESTAMP DEFAULT (strftime('%s','now')) );") + db)) + +(define (portlogger:open-run-close proc . params) + (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db")) + (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away + (handle-exceptions + exn + (begin + ;; (release-dot-lock fname) + (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "exn=" (condition->list exn)) + (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it + (print-call-chain (current-error-port))) + (let* (;; (lock (obtain-dot-lock fname 2 9 10)) + (db (portlogger:open-db fname)) + (res (apply proc db params))) + (sqlite3:finalize! db) + ;; (release-dot-lock fname) + res)))) + +;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) +(define (portlogger:take-port db portnum) + (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);")) + (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;")) + (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;")) + (res (sqlite3:with-transaction + db + (lambda () + ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;") + (let* ((curr #f) + (res #f)) + (set! curr (sqlite3:fold-row + (lambda (var curr) + (or curr var curr)) + "not-tried" + qry3 + portnum)) + ;; (print "curr=" curr) + (set! res (case (string->symbol curr) + ((released) (sqlite3:execute qry2 "taken" portnum) 'taken) + ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken) + ((taken) 'already-taken) + ((failed) 'failed) + (else 'error))) + ;; (print "res=" res) + res))))) + (sqlite3:finalize! qry1) + (sqlite3:finalize! qry2) + (sqlite3:finalize! qry3) + res)) + +(define (portlogger:get-prev-used-port db) + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "exn=" (condition->list exn)) + (print-call-chain (current-error-port)) + (debug:print 0 "Continuing anyway.") + #f) + (sqlite3:fold-row + (lambda (var curr) + (or curr var curr)) + #f + db + "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) + +(define (portlogger:find-port db) + (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) + (if (and val + (string->number val)) + (string->number val) + 32768))) + (portnum (or (portlogger:get-prev-used-port db) + (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range + (random (- 64000 lowport)))))) + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "exn=" (condition->list exn)) + (print-call-chain (current-error-port)) + (debug:print 0 "Continuing anyway.")) + (portlogger:take-port db portnum)) + portnum)) + +;; set port to "released", "failed" etc. +;; +(define (portlogger:set-port db portnum value) + (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum)) + +;; set port to failed (attempted to take but got error) +;; +(define (portlogger:set-failed db portnum) + (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)) + +;;====================================================================== +;; MAIN +;;====================================================================== + +(define (portlogger:main . args) + (let* ((dbfname (conc "/tmp/." (current-user-name) "-portlogger.db")) + (db (portlogger:open-db dbfname)) + (numargs (length args)) + (result + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain (current-error-port))) + (cond + ((> numargs 1) ;; most commands + (case (string->symbol (car args)) ;; commands with two or more params + ((take)(portlogger:take-port db (string->number (cadr args)))) + ((set) (portlogger:set-port db + (string->number (cadr args)) + (caddr args)) + (caddr args)) + ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))))) + (sqlite3:finalize! db) + result)) + +;; (print (apply portlogger:main (cdr (argv)))) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -51,10 +51,12 @@ ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) @@ -109,5 +111,30 @@ (begin (thread-sleep! 2) (loop (+ i 1))) (values pid-val exit-status exit-code)))))) +;;====================================================================== +;; MISC PROCESS RELATED STUFF +;;====================================================================== + +(define (process:children proc) + (with-input-from-pipe + (conc "ps h --ppid " (current-process-id) " -o pid") + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (let ((pid (string->number inl))) + (if proc (proc pid)) + (loop (read-line) (cons pid res)))))))) + +(define (process:alive? pid) + (handle-exceptions + exn + ;; possibly pid is a process not a child, look in /proc to see if it is running still + (file-exists? (conc "/proc/" pid)) + (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) + (and (number? rpid) + (equal? rpid pid))))) + ADDED rmt.scm Index: rmt.scm ================================================================== --- /dev/null +++ rmt.scm @@ -0,0 +1,577 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use json format) + +(declare (unit rmt)) +(declare (uses api)) +(declare (uses tdb)) +(declare (uses http-transport)) + +;; +;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! +;; + +;; ;; For debugging add the following to ~/.megatestrc +;; +;; (require-library trace) +;; (import trace) +;; (trace +;; rmt:send-receive +;; api:execute-requests +;; ) + + +;;====================================================================== +;; S U P P O R T F U N C T I O N S +;;====================================================================== + +;; #t means - please start a server! +;; +(define (rmt:write-frequency-over-limit? cmd run-id) + (and (not (member cmd api:read-only-queries)) + (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f)) + (record (if tmprec tmprec + (let ((v (vector (current-seconds) 0))) + (hash-table-set! *write-frequency* run-id v) + v))) + (count (+ 1 (vector-ref record 1))) + (start (vector-ref record 0)) + (queries-per-second (/ (* count 1.0) + (max (- (current-seconds) start) 1)))) + (vector-set! record 1 count) + (if (and (> count 10) + (> queries-per-second 10)) + (begin + (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) + #t) + #f)))) + +(define (rmt:get-connection-info run-id) + (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) + (if cinfo + cinfo + ;; NB// can cache the answer for server running for 10 seconds ... + ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) + (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) + (client:setup run-id) + #f)))) + +;; cmd is a symbol +;; vars is a json string encoding the parameters for the call +;; +(define (rmt:send-receive cmd rid params #!key (attemptnum 0)) + ;; clean out old connections + (mutex-lock! *db-multi-sync-mutex*) + (let ((expire-time (- (current-seconds) 60))) + (for-each + (lambda (run-id) + (let ((connection (hash-table-ref/default *runremote* run-id #f))) + (if (and connection + (< (http-transport:server-dat-get-last-access connection) expire-time)) + (begin + (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") + (hash-table-delete! *runremote* run-id))))) + (hash-table-keys *runremote*))) + (mutex-unlock! *db-multi-sync-mutex*) + (let* ((run-id (if rid rid 0)) + (connection-info (rmt:get-connection-info run-id)) + (jparams (db:obj->string params))) + (if connection-info + ;; use the server if have connection info + (let* ((dat (http-transport:client-api-send-receive run-id connection-info cmd jparams)) + (res (if (and dat (vector? dat)) (vector-ref dat 1) #f)) + (success (if (and dat (vector? dat)) (vector-ref dat 0) #f))) + (http-transport:server-dat-update-last-access connection-info) + (if success + (db:string->obj res) + ;; (if (< attemptnum 100) + ;; (begin + ;; (hash-table-delete! *runremote* run-id) + ;; (thread-sleep! 0.5) + ;; (rmt:send-receive cmd rid params attempnum: (+ attemptnum 1))) + ;; (begin + ;; (print-call-chain (current-error-port)) + ;; (debug:print 0 "ERROR: too many attempts to communicate have failed. Giving up. Kill your mtest processes and start over") + ;; (exit 1))))) + (begin ;; let ((new-connection-info (client:setup run-id))) + (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") + (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection + + ;; no longer killing the server in http-transport:client-api-send-receive + ;; may kill it here but what are the criteria? + ;; start with three calls then kill server + (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) + (thread-sleep! 2) + (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))) + (if (and (< attemptnum 10) + (tasks:need-server run-id)) + (begin + (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) + (rmt:send-receive cmd rid params (+ attemptnum 1))) + (rmt:open-qry-close-locally cmd run-id params))))) + +(define (rmt:update-db-stats run-id rawcmd params duration) + (mutex-lock! *db-stats-mutex*) + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: stats collection failed in update-db-stats") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + #f) ;; if this fails we don't care, it is just stats + (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) + (stat-vec (hash-table-ref/default *db-stats* cmd #f))) + (if (not stat-vec) + (let ((newvec (vector 0 0))) + (hash-table-set! *db-stats* cmd newvec) + (set! stat-vec newvec))) + (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) + (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) + (mutex-unlock! *db-stats-mutex*)) + + +(define (rmt:print-db-stats) + (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" + (debug:print 18 "DB Stats\n========") + (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (for-each (lambda (cmd) + (let ((cmd-dat (hash-table-ref *db-stats* cmd))) + (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) + (sort (hash-table-keys *db-stats*) + (lambda (a b) + (> (vector-ref (hash-table-ref *db-stats* a) 0) + (vector-ref (hash-table-ref *db-stats* b) 0))))))) + +(define (rmt:get-max-query-average run-id) + (mutex-lock! *db-stats-mutex*) + (let* ((runkey (conc "run-id=" run-id " ")) + (cmds (filter (lambda (x) + (substring-index runkey x)) + (hash-table-keys *db-stats*))) + (res (if (null? cmds) + (cons 'none 0) + (let loop ((cmd (car cmds)) + (tal (cdr cmds)) + (max-cmd (car cmds)) + (res 0)) + (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) + (tot (vector-ref cmd-dat 0)) + (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction + (currmax (max res curravg)) + (newmax-cmd (if (> curravg res) cmd max-cmd))) + (if (null? tal) + (if (> tot 10) + (cons newmax-cmd currmax) + (cons 'none 0)) + (loop (car tal)(cdr tal) newmax-cmd currmax))))))) + (mutex-unlock! *db-stats-mutex*) + res)) + +(define (rmt:open-qry-close-locally cmd run-id params) + (let* ((dbstruct-local (if *dbstruct-db* + *dbstruct-db* + (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (db (make-dbr:dbstruct path: dbdir local: #t))) + (set! *dbstruct-db* db) + db))) + (db-file-path (db:dbfile-path 0))) + ;; (read-only (not (file-read-access? db-file-path))) + (let* ((start (current-milliseconds)) + (res (api:execute-requests dbstruct-local (symbol->string cmd) params)) + (duration (- (current-milliseconds) start))) + (rmt:update-db-stats run-id cmd params duration) + ;; mark this run as dirty if this was a write + (if (not (member cmd api:read-only-queries)) + (let ((start-time (current-seconds))) + (mutex-lock! *db-multi-sync-mutex*) + ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f)) + ;; just set it every time. Is a write more expensive than a read and does it matter? + (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write" + (mutex-unlock! *db-multi-sync-mutex*))) + res))) + +(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) + (let* ((run-id (if run-id run-id 0)) + (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) + (dat (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + (if (and dat (vector-ref dat 0)) + (db:string->obj (vector-ref dat 1)) + (begin + (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) + dat)))) + +;; Wrap json library for strings (why the ports crap in the first place?) +(define (rmt:dat->json-str dat) + (with-output-to-string + (lambda () + (json-write dat)))) + +(define (rmt:json-str->dat json-str) + (with-input-from-string json-str + (lambda () + (json-read)))) + +;;====================================================================== +;; +;; A C T U A L A P I C A L L S +;; +;;====================================================================== + +;;====================================================================== +;; S E R V E R +;;====================================================================== + +(define (rmt:kill-server run-id) + (rmt:send-receive 'kill-server run-id (list run-id))) + +(define (rmt:start-server run-id) + (rmt:send-receive 'start-server 0 (list run-id))) + +;;====================================================================== +;; M I S C +;;====================================================================== + +(define (rmt:login run-id) + (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) + +;; This login does no retries under the hood - it acts a bit like a ping. +;; +(define (rmt:login-no-auto-client-setup connection-info run-id) + (rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) + +;; hand off a call to one of the db:queries statements +;; added run-id to make looking up the correct db possible +;; +(define (rmt:general-call stmtname run-id . params) + (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) + +(define (rmt:sync-inmem->db run-id) + (rmt:send-receive 'sync-inmem->db run-id '())) + +(define (rmt:sdb-qry qry val run-id) + ;; add caching if qry is 'getid or 'getstr + (rmt:send-receive 'sdb-qry run-id (list qry val))) + +;; NOT COMPLETED +(define (rmt:runtests user run-id testpatt params) + (rmt:send-receive 'runtests run-id testpatt)) + +;;====================================================================== +;; K E Y S +;;====================================================================== + +;; These require run-id because the values come from the run! +;; +(define (rmt:get-key-val-pairs run-id) + (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) + +(define (rmt:get-keys) + (rmt:send-receive 'get-keys #f '())) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (rmt:get-test-id run-id testname item-path) + (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) + +(define (rmt:get-test-info-by-id run-id test-id) + (if (and (number? run-id)(number? test-id)) + (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) + (begin + (debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (print-call-chain (current-error-port)) + #f))) + +(define (rmt:test-get-rundir-from-test-id run-id test-id) + (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) + +(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) + (let* ((test-path (if (string? work-area) + work-area + (rmt:test-get-rundir-from-test-id run-id test-id)))) + (debug:print 3 "TEST PATH: " test-path) + (open-test-db test-path))) + +;; WARNING: This currently bypasses the transaction wrapped writes system +(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) + +(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) + (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) + +(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) + (if (number? run-id) + (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)) + (begin + (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (print-call-chain (current-error-port)) + '()))) + +;; IDEA: Threadify these - they spend a lot of time waiting ... +;; +(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) + (let ((multi-run-mutex (make-mutex)) + (run-id-list (if run-ids + run-ids + (rmt:get-all-run-ids))) + (result '())) + (if (null? run-id-list) + '() + (for-each + (lambda (th) + + (thread-join! th)) ;; I assume that joining completed threads just moves on + (let loop ((hed (car run-id-list)) + (tal (cdr run-id-list)) + (threads '())) + (let* ((newthread (make-thread + (lambda () + (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) + (if (list? res) + (begin + (mutex-lock! multi-run-mutex) + (set! result (append result res)) + (mutex-unlock! multi-run-mutex)) + (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (conc "multi-run-thread for run-id " hed))) + (newthreads (cons newthread threads))) + (thread-start! newthread) + (thread-sleep! 0.5) ;; give that thread some time to start + (if (null? tal) + newthreads + (loop (car tal)(cdr tal) newthreads)))))) + result)) + +;; ;; IDEA: Threadify these - they spend a lot of time waiting ... +;; ;; +;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +;; (let ((run-id-list (if run-ids +;; run-ids +;; (rmt:get-all-run-ids)))) +;; (apply append (map (lambda (run-id) +;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) +;; run-id-list)))) + +(define (rmt:delete-test-records run-id test-id) + (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) + +;; This is not needed as test steps are deleted on test delete call +;; +;; (define (rmt:delete-test-step-records run-id test-id) +;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) + +(define (rmt:test-set-status-state run-id test-id status state msg) + (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg))) + +(define (rmt:test-toplevel-num-items run-id test-name) + (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) + +;; (define (rmt:get-previous-test-run-record run-id test-name item-path) +;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) + +(define (rmt:get-matching-previous-test-run-records run-id test-name item-path) + (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) + +(define (rmt:test-get-logfile-info run-id test-name) + (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) + +(define (rmt:test-get-records-for-index-file run-id test-name) + (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) + +(define (rmt:get-testinfo-state-status run-id test-id) + (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) + +(define (rmt:test-set-log! run-id test-id logf) + (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) + +(define (rmt:test-set-top-process-pid run-id test-id pid) + (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) + +(define (rmt:test-get-top-process-pid run-id test-id) + (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) + +(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) + (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) + +;; NOTE: This will open and access ALL run databases. +;; +(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) + (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) + (apply append + (map (lambda (run-id) + (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) + run-ids)))) + +(define (rmt:get-run-ids-matching keynames target res) + (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) + +(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))) + (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode))) + +(define (rmt:get-count-tests-running-for-run-id run-id) + (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) + +;; Statistical queries + +(define (rmt:get-count-tests-running run-id) + (rmt:send-receive 'get-count-tests-running run-id (list run-id))) + +(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) + (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) + +(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) + (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status))) + +(define (rmt:update-pass-fail-counts run-id test-name) + (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +(define (rmt:get-run-info run-id) + (rmt:send-receive 'get-run-info run-id (list run-id))) + +;; Use the special run-id == #f scenario here since there is no run yet +(define (rmt:register-run keyvals runname state status user) + (rmt:send-receive 'register-run #f (list keyvals runname state status user))) + +(define (rmt:get-run-name-from-id run-id) + (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) + +(define (rmt:delete-run run-id) + (rmt:send-receive 'delete-run run-id (list run-id))) + +(define (rmt:delete-old-deleted-test-records) + (rmt:send-receive 'delete-old-deleted-test-records #f '())) + +(define (rmt:get-runs runpatt count offset keypatts) + (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) + +(define (rmt:get-runs runpatt count offset keypatts) + (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) + +(define (rmt:get-all-run-ids) + (rmt:send-receive 'get-all-run-ids #f '())) + +(define (rmt:get-prev-run-ids run-id) + (rmt:send-receive 'get-prev-run-ids #f (list run-id))) + +(define (rmt:lock/unlock-run run-id lock unlock user) + (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) + +;; set/get status +(define (rmt:get-run-status run-id) + (rmt:send-receive 'get-run-status #f (list run-id))) + +(define (rmt:set-run-status run-id run-status #!key (msg #f)) + (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) + +(define (rmt:update-run-event_time run-id) + (rmt:send-receive 'update-run-event_time #f (list run-id))) + +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) + (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit))) + +(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) + (rmt:send-receive 'find-and-mark-incomplete run-id (list run-id ovr-deadtime))) + +;;====================================================================== +;; M U L T I R U N Q U E R I E S +;;====================================================================== + +;; Need to move this to multi-run section and make associated changes +(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) + (let ((run-ids (rmt:get-all-run-ids))) + (for-each (lambda (run-id) + (rmt:find-and-mark-incomplete run-id ovr-deadtime)) + run-ids))) + +;; get the previous record for when this test was run where all keys match but runname +;; returns #f if no such test found, returns a single test record if found +;; +;; Run this at the client end since we have to connect to multiple run-id dbs +;; +(define (rmt:get-previous-test-run-record run-id test-name item-path) + (let* ((keyvals (rmt:get-key-val-pairs run-id)) + (keys (rmt:get-keys)) + (selstr (string-intersperse keys ",")) + (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) + (if (not keyvals) + #f + (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) + ;; for each run starting with the most recent look to see if there is a matching test + ;; if found then return that matching test record + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) #f + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (if (and (null? results) + (not (null? tal))) + (loop (car tal)(cdr tal)) + (if (null? results) #f + (car results)))))))))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; Getting steps is more complicated. +;; +;; If given work area +;; 1. Find the testdat.db file +;; 2. Open the testdat.db file and do the query +;; If not given the work area +;; 1. Do a remote call to get the test path +;; 2. Continue as above +;; +(define (rmt:get-steps-for-test run-id test-id) + (rmt:send-receive 'get-steps-data run-id (list test-id))) + +(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) + (let* ((state (items:check-valid-items "state" state-in)) + (status (items:check-valid-items "status" status-in))) + (if (or (not state)(not status)) + (debug:print 3 "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) + +(define (rmt:get-steps-for-test run-id test-id) + (rmt:send-receive 'get-steps-for-test run-id (list test-id))) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== + +(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) + (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) + (if tdb + (tdb:read-test-data tdb test-id categorypatt) + '()))) + +(define (rmt:testmeta-add-record testname) + (rmt:send-receive 'testmeta-add-record #f (list testname))) + +(define (rmt:testmeta-get-record testname) + (rmt:send-receive 'testmeta-get-record #f (list testname))) + +(define (rmt:testmeta-update-field test-name fld val) + (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) + +(define (rmt:test-data-rollup run-id test-id status) + (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) + +(define (rmt:csv->test-data run-id test-id csvdata) + (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ADDED rmtdb.scm Index: rmtdb.scm ================================================================== --- /dev/null +++ rmtdb.scm @@ -0,0 +1,11 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + ADDED run-tests-queue-new.scm Index: run-tests-queue-new.scm ================================================================== --- /dev/null +++ run-tests-queue-new.scm Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -7,10 +7,25 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== +(define-inline (runs:runrec-make-record) (make-vector 13)) +(define-inline (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c +(define-inline (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string +(define-inline (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d% +(define-inline (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...) +(define-inline (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) +(define-inline (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val +(define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config +(define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config +(define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) +(define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http +(define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) +(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* +(define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id + (define-inline (test:get-id vec) (vector-ref vec 0)) (define-inline (test:get-run_id vec) (vector-ref vec 1)) (define-inline (test:get-test-name vec)(vector-ref vec 2)) (define-inline (test:get-state vec) (vector-ref vec 3)) (define-inline (test:get-status vec) (vector-ref vec 4)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -8,24 +8,18 @@ (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") - - -;; (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t)) -(define (setup-env-defaults fname run-id already-seen keys keyvals #!key (environ-patt #f)(change-env #t)) - (let* (;; (keys (db:get-keys db)) - ;; (keyvals (if run-id (db:get-key-vals db run-id) #f)) - (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/") - (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - (begin - (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") - "nothing matches this I hope"))))) +(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) + (let* ((keys (map car keyvals)) + (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") + (or (common:args-get-target) + (get-environment-variable "MT_TARGET") + (begin + (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") + "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) (whatfound (make-hash-table)) (finaldat (make-hash-table)) @@ -32,24 +26,27 @@ (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code (debug:print 4 "Using key=\"" thekey "\"") (if change-env - (for-each - (lambda (key val) - (setenv (vector-ref key 0) val)) - keys keyvals)) + (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. + (lambda (keyval) + (safe-setenv (car keyval)(cadr keyval))) + keyvals)) (for-each (lambda (section) (let ((section-dat (hash-table-ref/default confdat section #f))) (if section-dat (for-each (lambda (envvar) (let ((val (cadr (assoc envvar section-dat)))) (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) - (if change-env (setenv envvar val)) + (if (and (string? envvar) + (string? val) + change-env) + (safe-setenv envvar val)) (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin @@ -59,20 +56,20 @@ sections) (debug:print 2 "---") (set! *already-seen-runconfig-info* #t))) finaldat)) -(define (set-run-config-vars db run-id keys keyvals) - (push-directory *toppath*) +(define (set-run-config-vars run-id keyvals targ-from-db) + (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... (let ((runconfigf (conc *toppath* "/runconfigs.config")) - (targ (or (args:get-arg "-target") - (args:get-arg "-reqtarg") - (db:get-target db run-id)))) + (targ (or (common:args-get-target) + targ-from-db + (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id #t keys keyvals + (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) ADDED runs-launch-loop-test.scm Index: runs-launch-loop-test.scm ================================================================== --- /dev/null +++ runs-launch-loop-test.scm @@ -0,0 +1,59 @@ +(use srfi-69) + +(define (runs:queue-next-hed tal reg n regful) + (if regful + (car reg) + (car tal))) + +(define (runs:queue-next-tal tal reg n regful) + (if regful + tal + (let ((newtal (cdr tal))) + (if (null? newtal) + reg + newtal + )))) + +(define (runs:queue-next-reg tal reg n regful) + (if regful + (cdr reg) + (if (eq? (length tal) 1) + '() + reg))) + +(use trace) +(trace runs:queue-next-hed + runs:queue-next-tal + runs:queue-next-reg) + + +(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) + +(define test-registry (make-hash-table)) + +(define n 3) + +(let loop ((hed (car tests)) + (tal (cdr tests)) + (reg '())) + (let* ((reglen (length reg)) + (regful (> reglen n))) + (print "hed=" hed ", length reg=" (length reg) ", (> lenreg n)=" (> (length reg) n)) + (let ((newtal (append tal (list hed)))) ;; used if we are not done with this test + (cond + ((not (hash-table-ref/default test-registry hed #f)) + (hash-table-set! test-registry hed #t) + (print "Registering #" hed) + (if (not (null? tal)) + (loop (runs:queue-next-hed tal reg n regful) + (runs:queue-next-tal tal reg n regful) + (let ((newl (append reg (list hed)))) + (if regful + (cdr newl) + newl))))) + (else + (print "Running #" hed) + (if (not (null? tal)) + (loop (runs:queue-next-hed tal reg n regful) + (runs:queue-next-tal tal reg n regful) + (runs:queue-next-reg tal reg n regful)))))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -18,134 +18,163 @@ (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) +(declare (uses mt)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -;; runs:get-runs-by-patt -;; get runs by list of criteria -;; register a test run with the db -;; -;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -;; to extract info from the structure returned -;; -(define (runs:get-runs-by-patt db keys runnamepatt) ;; test-name) - (let* ((keyvallst (keys->vallist keys)) - (tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) - (keystr (car tmp)) - (header (cadr tmp)) - (res '()) - (key-patt "") - (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) - (qry-str #f)) - (for-each (lambda (keyval) - (let* ((key (vector-ref keyval 0)) - (fulkey (conc ":" key)) - (patt (args:get-arg fulkey)) - (wildtype (if (substring-index "%" patt) "like" "glob"))) - (if patt - (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) - (begin - (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) - (exit 6))))) - keys) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";")) - (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt) - (vector header res))) - (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) -(define (db:get-run-key-val db run-id key) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") - run-id) - res)) - -(define (db:get-run-name-from-id db run-id) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (runname) - (set! res runname)) - db - "SELECT runname FROM runs WHERE id=?;" - run-id) - res)) - -(define (set-megatest-env-vars run-id) - (let ((keys (cdb:remote-run db:get-keys #f)) - (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) +;; This is the *new* methodology. One record to inform them and in the chaos, organise them. +;; +(define (runs:create-run-record) + (let* ((mconfig (if *configdat* + *configdat* + (if (launch:setup-for-run) + *configdat* + (begin + (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") + (exit 1))))) + (runrec (runs:runrec-make-record)) + (target (common:args-get-target)) + (runname (or (args:get-arg "-runname") + (args:get-arg ":runname"))) + (testpatt (or (args:get-arg "-testpatt") + (args:get-arg "-runtests"))) + (keys (keys:config-get-fields mconfig)) + (keyvals (keys:target->keyval keys target)) + (toppath *toppath*) + (envdat keyvals) ;; initial values start with keyvals + (runconfig #f) + (serverdat (if (args:get-arg "-server") + *runremote* + #f)) ;; to be used later + (transport (or (args:get-arg "-transport") 'http)) + (run-id #f)) + ;; Set all the environment vars we know so far, start with keys + (for-each (lambda (keyval) + (setenv (car keyval)(cadr keyval))) + keyvals) + ;; Set up various and sundry known vars here + (setenv "MT_RUN_AREA_HOME" toppath) + (setenv "MT_RUNNAME" runname) + (setenv "MT_TARGET" target) + (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) + (set! envdat (append + envdat + (list (list "MT_RUN_AREA_HOME" toppath) + (list "MT_RUNNAME" runname) + (list "MT_TARGET" target)))) + ;; Now can read the runconfigs file + ;; + (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) + (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) + (begin + (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (if db (sqlite3:finalize! db)) + (exit 1))) + ;; Now have runconfigs data loaded, set environment vars + (for-each (lambda (section) + (for-each (lambda (varval) + (set! envdat (append envdat (list varval))) + (safe-setenv (car varval)(cadr varval))) + (configf:get-section runconfig section))) + (list "default" target)) + (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) + +(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) + (let* ((target (or (common:args-get-target) + (get-environment-variable "MT_TARGET"))) + (keys (if inkeys inkeys (rmt:get-keys))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) + (link-tree (configf:lookup *configdat* "setup" "linktree"))) ;; get the info from the db and put it in the cache + (if link-tree + (setenv "MT_LINKTREE" link-tree) + (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) - (hash-table-set! vals key (cdb:remote-run db:get-run-key-val #f run-id key))) - keys))) + (hash-table-set! vals (car key) (cadr key))) + keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) - (debug:print 2 "setenv " (key:get-fieldname key) " " val) - (setenv (key:get-fieldname key) val))) + (debug:print 2 "setenv " key " " val) + (safe-setenv key val))) + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (setenv "MT_RUNNAME" (cdb:remote-run db:get-run-name-from-id #f run-id)) - (setenv "MT_RUN_AREA_HOME" *toppath*) - )) + (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) + (if runname + (setenv "MT_RUNNAME" runname) + (debug:print 0 "ERROR: no value for runname for id " run-id))) + (setenv "MT_RUN_AREA_HOME" *toppath*))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) +;; Every time can-run-more-tests is called increment the delay +;; +;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine +;; (define *last-num-running-tests* 0) -(define *runs:can-run-more-tests-delay* 0) -(define (runs:shrink-can-run-more-tests-delay) - (set! *runs:can-run-more-tests-delay* 0)) ;; (/ *runs:can-run-more-tests-delay* 2))) - -(define (runs:can-run-more-tests test-record) - (thread-sleep! *runs:can-run-more-tests-delay*) - (let* ((tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) - ;; Heuristic fix. These are getting called too rapidly when jobs are running or stuck - ;; so we are going to increment a global delay by 0.1 seconds up to 10 seconds - ;; every time runs:can-run-more-tests is called. - ;; when a test is launched or other activity occurs divide the delay by 2 - (num-running (cdb:remote-run db:get-count-tests-running #f)) - (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) - (if (and mcj (string->number mcj)) - (string->number mcj) - 1))) - (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) - (if (and (> (+ num-running num-running-in-jobgroup) 0) - (< *runs:can-run-more-tests-delay* 1)) +(define *runs:can-run-more-tests-count* 0) +(define (runs:shrink-can-run-more-tests-count) + (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) + +;; Temporary globals. Move these into the logic or into common +;; +(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run +(define (runs:inc-cant-run-tests testname) + (hash-table-set! *seen-cant-run-tests* testname + (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) + +(define (runs:can-keep-running? testname n) + (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) + +(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran + +(define (runs:lownoise key waitval) + (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) (begin - (set! *runs:can-run-more-tests-delay* (+ *runs:can-run-more-tests-delay* 0.009)) - (debug:print-info 14 "can-run-more-tests-delay: " *runs:can-run-more-tests-delay*))) + (hash-table-set! *runs:denoise* key currtime) + #t) + #f))) + +(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) + ;;(thread-sleep! (cond + ;; ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while + ;; (else 0))) + (let* ((num-running (rmt:get-count-tests-running run-id)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) + (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (if (string? jobg-count) + (string->number jobg-count) + jobg-count)))) + (if (> (+ num-running num-running-in-jobgroup) 0) + (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) @@ -152,130 +181,137 @@ (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) - (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running - ", max_concurrent_jobs: " max-concurrent-jobs) + (if (runs:lownoise "mcj msg" 60) + (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running + ", max_concurrent_jobs: " max-concurrent-jobs)) #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup - " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) + (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) + (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) -;;====================================================================== -;; New methodology. These routines will replace the above in time. For -;; now the code is duplicated. This stuff is initially used in the monitor -;; based code. -;;====================================================================== - -;; register a test run with the db -(define (runs:register-run db keys keyvallst runname state status user) - (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) - (let* ((keystr (keys->keystr keys)) - (comma (if (> (length keys) 0) "," "")) - (andstr (if (> (length keys) 0) " AND " "")) - (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvals (map cadr keyvallst)) - (allvals (append (list runname state status user) keyvals)) - (qryvals (append (list runname) keyvals)) - (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) - (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") - (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" - (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") - allvals) - (apply sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 "qry: " qry) - qry) - qryvals) - (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) - res) - (begin - (debug:print 0 "ERROR: Called without all necessary keys") - #f)))) - -;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. -;; keyvals. -;; + ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-names test-patts user flags) - (common:clear-caches) ;; clear all caches - (let* ((db #f) - (keys (cdb:remote-run db:get-keys #f)) - (keyvallst (keys:target->keyval keys target)) - (run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) - (keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) - (deferred '()) ;; delay running these since they have a waiton clause - ;; keepgoing is the defacto modality now, will add hit-n-run a bit later - ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - (runconfigf (conc *toppath* "/runconfigs.config")) - (required-tests '()) - (test-records (make-hash-table))) - - (set-megatest-env-vars run-id) ;; these may be needed by the launching process - +(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names + (let* ((keys (keys:config-get-fields *configdat*)) + (keyvals (keys:target->keyval keys target)) + (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) + (deferred '()) ;; delay running these since they have a waiton clause + (runconfigf (conc *toppath* "/runconfigs.config")) + (test-records (make-hash-table)) + ;; need to process runconfigs before generating these lists + (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names + (all-test-names #f) ;; (hash-table-keys all-tests-registry)) + (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) + (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work + (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) + (tdbdat (tasks:open-db))) + + (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + + (set-signal-handler! signal/int + (lambda (signum) + (signal-mask! signum) + (print "Received signal " signum ", cleaning up before exit. Please wait...") + (let ((tdbdat (tasks:open-db))) + (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "killed")) + (print "Killed by signal " signum ". Exiting") + (exit))) + + ;; register this run in monitor.db + (tasks:add (db:delay-if-busy tdbdat) "run-tests" user target runname test-patts task-key) ;; params) + (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "running") + (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + + ;; Now generate all the tests lists + (set! all-tests-registry (tests:get-all)) + (set! all-test-names (hash-table-keys all-tests-registry)) + (set! test-names (tests:filter-test-names all-test-names test-patts)) + (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - (set! test-names (tests:get-valid-tests *toppath* test-names)) - (set! test-names (delete-duplicates test-names)) - - (debug:print-info 0 "test names " test-names) + ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) + (debug:print-info 0 "tests search path: " (tests:get-tests-search-path *configdat*)) + (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin + ;; Is this still necessary? I think not. Unreachable tests are marked as such and + ;; should not cause problems here. + ;; ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") - (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + ;; + ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") + + ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED + ;; + (for-each (lambda (state) + (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) + (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) - ;; from here on out the db will be opened and closed on every call runs:run-tests-queue - ;; (sqlite3:finalize! db) + ;; Ensure all tests are registered in the test_meta table + (runs:update-all-test_meta #f) + ;; now add non-directly referenced dependencies (i.e. waiton) + ;;====================================================================== + ;; refactoring this block into tests:get-full-data + ;; + ;; What happended, this code is now duplicated in tests!? + ;; + ;;====================================================================== (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 "hed=" hed " at top of loop") - (let* ((config (tests:get-testconfig hed 'return-procs)) + (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. + (setenv "MT_TEST_NAME" hed) ;; + (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print 0 "ERROR: non-existent required test \"" hed "\"") - (if db (sqlite3:finalize! db)) (exit 1))))) (debug:print-info 8 "waitons string is " instr) - (string-split (cond - ((procedure? instr) - (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " hed) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) - "")))))) + (let ((newwaitons + (string-split (cond + ((procedure? instr) + (let ((res (instr))) + (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + ""))))) + (filter (lambda (x) + (if (hash-table-ref/default all-tests-registry x #f) + #t + (begin + (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) + #f))) + newwaitons))))) (debug:print-info 8 "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin @@ -308,11 +344,11 @@ (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now (debug:print-info 4 "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) + " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path ))) @@ -329,27 +365,814 @@ (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) - (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts) - (debug:print-info 4 "All done by here"))) + (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) + (if (> (length (hash-table-keys test-records)) 0) + (let* ((keep-going #t) + (th1 (make-thread (lambda () + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) + "runs:run-tests-queue")) + (th2 (make-thread (lambda () + ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... + (let ((run-ids (rmt:get-all-run-ids))) + (for-each (lambda (run-id) + (if keep-going + (rmt:find-and-mark-incomplete run-id #f))) ;; ovr-deadtime))) + run-ids))) + "runs: mark-incompletes"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (set! keep-going #f) + (thread-join! th2) + ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD + (if (> run-count 0) + (begin + (if (not (hash-table-ref/default flags "-preclean" #f)) + (hash-table-set! flags "-preclean" #t)) + (if (not (hash-table-ref/default flags "-rerun" #f)) + (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) + (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) + (debug:print-info 0 "No tests to run"))) + (debug:print-info 4 "All done by here") + (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "done") + ;; (sqlite3:finalize! tasks-db) + )) + + +;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. +;; +;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns +;; If reg is full (i.e. length >= n +;; loop with (car reg) tal (cdr reg) reruns +;; If tal is empty +;; but have items in reg; loop with (car reg)(cdr reg) '() reruns +;; If reg is empty => all done + +(define (runs:queue-next-hed tal reg n regfull) + (if regfull + (car reg) + (if (null? tal) ;; tal is used up, pop from reg + (car reg) + (car tal)))) + +;; (cond +;; ((and regfull (null? reg)(not (null? tal))) (car tal)) +;; ((and regfull (not (null? reg))) (car reg)) +;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) +;; ((and (not regfull)(not (null? tal))) (car tal)) +;; (else +;; (debug:print 0 "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; #f))) + +(define (runs:queue-next-tal tal reg n regfull) + (if regfull + tal + (if (null? tal) ;; must transfer from reg + (cdr reg) + (cdr tal)))) + +(define (runs:queue-next-reg tal reg n regfull) + (if regfull + (cdr reg) + (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal + '() + reg))) + +(define runs:nothing-left-in-queue-count 0) + +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap) + (let* ((loop-list (list hed tal reg reruns)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) + ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) + (fails (runs:calc-fails prereqs-not-met)) + (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (runnables (runs:calc-runnable prereqs-not-met))) + (debug:print-info 4 "START OF INNER COND #2 " + "\n can-run-more: " can-run-more + "\n testname: " hed + "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) + "\n non-completed: " (runs:pretty-string non-completed) + "\n prereq-fails: " (runs:pretty-string prereq-fails) + "\n fails: " (runs:pretty-string fails) + "\n testmode: " testmode + "\n (member 'toplevel testmode): " (member 'toplevel testmode) + "\n (null? non-completed): " (null? non-completed) + "\n reruns: " reruns + "\n items: " items + "\n can-run-more: " can-run-more) + + (cond + ;; all prereqs met, fire off the test + ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch + + ((and (not (member 'toplevel testmode)) + (member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) + '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here + (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") + (if (or (not (null? tal)) + (not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + (begin + (debug:print-info 0 "Nothing left in the queue!") + ;; If get here twice then we know we've tried to expand all items + ;; since there must be a logic issue with the handling of loops in the + ;; items expand phase we will brute force an exit here. + (if (> runs:nothing-left-in-queue-count 2) + (begin + (debug:print 0 "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") + (exit 0)) + (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) + #f))) + + ;; + ((or (null? prereqs-not-met) + (and (member 'toplevel testmode) + (null? non-completed))) + (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") + (let ((test-name (tests:testqueue-get-testname test-record))) + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" runname) + (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (let ((items-list (items:get-items-from-config tconfig))) + (if (list? items-list) + (begin + (if (null? items-list) + (let ((test-id (rmt:get-test-id run-id test-name ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))) + (tests:testqueue-set-items! test-record items-list) + (list hed tal reg reruns)) + (begin + (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") + (exit 1)))))) + + ((and (null? fails) + (null? prereq-fails) + (not (null? non-completed))) + (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + (append newtal reruns))) + ;; prereqstrs is a list of test names as strings that are prereqs for hed + (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + prereqs-not-met))) + ;; a prereq that is not found in allinqueue will be put in the notinqueue list + ;; + ;; (notinqueue (filter (lambda (x) + ;; (not (member x allinqueue))) + ;; prereqstrs)) + (give-up #f)) + + ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. + ;; We need to use this to dequeue this item as CANNOTRUN + ;; + (if (member testmode '(toplevel)) + (for-each (lambda (prereq) + (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) + (set! give-up #t))) + prereqstrs)) + + (if (and give-up + (not (and (null? tal)(null? reg)))) + (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) + (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) + (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) + + (if (and (null? trimmed-tal) + (null? trimmed-reg)) + #f + (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) + reruns))) + (list (car newtal)(append (cdr newtal) reg) '() reruns)))) + + ((and (null? fails) + (null? prereq-fails) + (null? non-completed)) + (if (runs:can-keep-running? hed 20) + (begin + (runs:inc-cant-run-tests hed) + (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) + ;; getting here likely means the system is way overloaded, kill a full minute before continuing + (thread-sleep! 60) + ;; num-retries code was here + ;; we use this opportunity to move contents of reg to tal + (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? + (begin + (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns)))) + + ((and + (or (not (null? fails)) + (not (null? prereq-fails))) + (member 'normal testmode)) + (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") + ", removing it from to-do list") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id + (if (not (null? prereq-fails)) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) + (if (or (not (null? reg))(not (null? tal))) + (begin + (hash-table-set! test-registry hed 'CANNOTRUN) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + (cons hed reruns))) + #f)) ;; #f flags do not loop + + ((and (not (null? fails))(member 'toplevel testmode)) + (if (or (not (null? reg))(not (null? tal))) + (list (car newtal)(append (cdr newtal) reg) '() reruns) + #f)) + ((null? runnables) #f) ;; if we get here and non-completed is null the it's all over. + (else + (debug:print 0 "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + ;; (list (runs:queue-next-hed tal reg reglen regfull) + ;; (runs:queue-next-tal tal reg reglen regfull) + ;; (runs:queue-next-reg tal reg reglen regfull) + ;; reruns) + (list (car newtal)(cdr newtal) reg reruns))))) + +(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) + (if (null? inlst) + '() + (map (lambda (t) + (cond + ((vector? t) + (let ((test-name (db:test-get-testname t)) + (item-path (db:test-get-item-path t)) + (test-state (db:test-get-state t)) + (test-status (db:test-get-status t))) + (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status))) + ((string? t) + t) + (else + (conc t)))) + inlst))) + +(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap) + (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (num-running-in-jobgroup (list-ref run-limits-info 2)) + (max-concurrent-jobs (list-ref run-limits-info 3)) + (job-group-limit (list-ref run-limits-info 4)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) + ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (loop-list (list hed tal reg reruns)) + ;; configure the load runner + (numcpus (common:get-num-cpus)) + (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) + (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) + (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" + (string-intersperse + (map (lambda (t) + (if (vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc " WARNING: t is not a vector=" t ))) + prereqs-not-met) ", ") ") fails: " fails) + + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + + ;; Don't know at this time if the test have been launched at some time in the past + ;; i.e. is this a re-launch? + (debug:print-info 4 "run-limits-info = " run-limits-info) + + (cond + + ;; Check item path against item-patts, + ;; + ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run + ;; else the run is stuck, temporarily or permanently + ;; but should check if it is due to lack of resources vs. prerequisites + (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; Register tests + ;; + ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) + (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) + ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + (let register-loop ((numtries 15)) + (rmt:general-call 'register-test run-id run-id test-name item-path) + (thread-sleep! 0.5) + (if (rmt:get-test-id run-id test-name item-path) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) + (if (> numtries 0) + (register-loop (- numtries 1)) + (debug:print 0 "ERROR: failed to register test " (runs:make-full-test-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) + (begin + (rmt:general-call 'register-test run-id run-id test-name "") + (if (rmt:get-test-id run-id test-name "") + (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (if (and (null? tal)(null? reg)) + (list hed tal (append reg (list hed)) reruns) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + ;; NB// Here we are building reg as we register tests + ;; if regfull we must pop the front item off reg + (if regfull + (append (cdr reg) (list hed)) + (append reg (list hed))) + reruns))) + + ;; At this point hed test registration must be completed. + ;; + ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) + 'start) + (debug:print-info 0 "Waiting on test registration(s): " + (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registry x #f) 'start)) + (hash-table-keys test-registry)) + ", ")) + (thread-sleep! 0.1) + (list hed tal reg reruns)) + + ;; If no resources are available just kill time and loop again + ;; + ((not have-resources) ;; simply try again after waiting a second + (if (runs:lownoise "no resources" 60) + (debug:print-info 1 "no resources to run new tests, waiting ...")) + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + (thread-sleep! 1) + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (list (car newtal)(cdr newtal) reg reruns)) + + ;; This is the final stage, everything is in place so launch the test + ;; + ((and have-resources + (or (null? prereqs-not-met) + (and (eq? testmode 'toplevel) + (null? non-completed)))) + ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path)) + ;; we are going to reset all the counters for test retries by setting a new hash table + ;; this means they will increment only when nothing can be run + (set! *max-tries-hash* (make-hash-table)) + ;; well, first lets see if cpu load throttling is enabled. If so wait around until the + ;; average cpu load is under the threshold before continuing + (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified + (common:wait-for-cpuload maxload numcpus waitdelay)) + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; must be we have unmet prerequisites + ;; + (else + (debug:print 4 "FAILS: " fails) + ;; If one or more of the prereqs-not-met are FAIL then we can issue + ;; a message and drop hed from the items to be processed. + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 1 "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) + (if (null? fails) + (begin + ;; couldn't run, take a breather + (if (runs:lownoise "Waiting for more work to do..." 60) + (debug:print-info 0 "Waiting for more work to do...")) + (thread-sleep! 1) + (list (car newtal)(cdr newtal) reg reruns)) + ;; the waiton is FAIL so no point in trying to run hed ever again + (if (or (not (null? reg))(not (null? tal))) + (if (vector? hed) + (begin + (debug:print 1 "WARNING: Dropping test " test-name "/" item-path + " from the launch list as it has prerequistes that are FAIL") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + ;; This next is for the items + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? + )) + (let ((nth-try (hash-table-ref/default test-registry hed 0))) + (cond + ((member "RUNNING" (map db:test-get-state prereqs-not-met)) + (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) + (debug:print 0 "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (thread-sleep! 4) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)) + ((or (not nth-try) + (and (number? nth-try) + (< nth-try 10))) + (hash-table-set! test-registry hed (if (number? nth-try) + (+ nth-try 1) + 0)) + (if (runs:lownoise (conc "not removing test " hed) 60) + (debug:print 1 "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (list hed tal reg reruns) + ;; (list (car newtal)(cdr newtal) reg reruns) + ;; (hash-table-set! test-registry hed 'removed) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)) + ((symbol? nth-try) + (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW + (if (null? tal) + #f ;; yes, really + (list (car tal)(cdr tal) reg reruns)) + (begin + (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) + (debug:print 0 "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) + (hash-table-set! test-registry hed 0) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)))) + (else + (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) + (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 " prereqs: " prereqs-not-met) + (hash-table-set! test-registry hed 'removed) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) + (mt:roll-up-pass-fail-counts run-id test-name item-path "FAIL") ;; treat as FAIL + (list (if (null? tal)(car newtal)(car tal)) + tal + reg + reruns))))) + ;; can't drop this - maybe running? Just keep trying + (let ((runable-tests (runs:runable-tests prereqs-not-met))) + (if (null? runable-tests) + #f ;; I think we are truly done here + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns))))))))) + +;; scan a list of tests looking to see if any are potentially runnable +(define (runs:runable-tests tests) + (filter (lambda (t) + (if (not (vector? t)) + t + (let ((state (db:test-get-state t)) + (status (db:test-get-status t))) + (case (string->symbol state) + ((COMPLETED) #f) + ((NOT_STARTED) + (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" )) + #f + t)) + ((DELETED) #f) + (else t))))) + tests)) + +;; every time though the loop increment the test/itempatt val. +;; when the min is > max-allowed and none running then force exit +;; +(define *max-tries-hash* (make-hash-table)) + +;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) + ;; At this point the list of parent tests is expanded + ;; NB// Should expand items here and then insert into the run queue. + (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) + + ;; Do mark-and-find clean up of db before starting runing of quue + ;; + ;; (cdb:remote-run db:find-and-mark-incomplete #f) + + (let ((run-info (rmt:get-run-info run-id)) + (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) + (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) + (test-registry (make-hash-table)) + (registry-mutex (make-mutex)) + (num-retries 0) + (max-retries (config-lookup *configdat* "setup" "maxretries")) + (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (if (and mcj (string->number mcj)) + (string->number mcj) + 1))) ;; length of the register queue ahead + (reglen (if (number? reglen-in) reglen-in 1)) + (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle + (last-time-some-running (current-seconds)) + (tdbdat (tasks:open-db))) + + ;; Initialize the test-registery hash with tests that already have a record + ;; convert state to symbol and use that as the hash value + (for-each (lambda (trec) + (let ((id (db:test-get-id trec)) + (tn (db:test-get-testname trec)) + (ip (db:test-get-item-path trec)) + (st (db:test-get-state trec))) + (if (not (equal? st "DELETED")) + (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st))))) + tests-info) + (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) + + (let loop ((hed (car sorted-test-names)) + (tal (cdr sorted-test-names)) + (reg '()) ;; registered, put these at the head of tal + (reruns '())) + + (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; moving this to a parallel thread and just run it once. + ;; + (if (> (current-seconds)(+ last-time-incomplete 900)) + (begin + (set! last-time-incomplete (current-seconds)) + ;; (rmt:find-and-mark-incomplete-all-runs) + )) + + ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) + (let* ((test-record (hash-table-ref test-records hed)) + (test-name (tests:testqueue-get-testname test-record)) + (tconfig (tests:testqueue-get-testconfig test-record)) + (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) + (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) + (if m (map string->symbol (string-split m)) '(normal)))) + (itemmap (configf:lookup tconfig "requirements" "itemmap")) + (waitons (tests:testqueue-get-waitons test-record)) + (priority (tests:testqueue-get-priority test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f + (items (tests:testqueue-get-items test-record)) + (item-path (item-list->path itemdat)) + (tfullname (runs:make-full-test-name test-name item-path)) + (newtal (append tal (list hed))) + (regfull (>= (length reg) reglen)) + (num-running (rmt:get-count-tests-running-for-run-id run-id))) + + ;; every couple minutes verify the server is there for this run + (if (and (common:low-noise-print 60 "try start server" run-id) + (tasks:need-server run-id)) + (tasks:start-and-wait-for-server tdbdat run-id 10)) + + (if (> num-running 0) + (set! last-time-some-running (current-seconds))) + + (if (> (current-seconds)(+ last-time-some-running 240)) + (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) + ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) + + ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard + ;; and it is clear they *should* have run but did not. + (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) + (begin + (rmt:general-call 'register-test run-id run-id test-name "") + (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) + + ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( + ;; + (if (member (hash-table-ref/default test-registry tfullname #f) + '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) + (begin + (if (runs:lownoise (conc "been marked do not run " tfullname) 60) + (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) + (if (or (not (null? tal))(not (null? reg))) + (loop (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns)))) + ;; (loop (car tal)(cdr tal) reg reruns)))) + + (debug:print 4 "TOP OF LOOP => " + "test-name: " test-name + "\n test-record " test-record + "\n hed: " hed + "\n itemdat: " itemdat + "\n items: " items + "\n item-path: " item-path + "\n waitons: " waitons + "\n num-retries: " num-retries + "\n tal: " tal + "\n reruns: " reruns + "\n regfull: " regfull + "\n reglen: " reglen + "\n length reg: " (length reg) + "\n reg: " reg) + + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member test-name waitons) + (begin + (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) + + (cond + + ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF + ;; they have been through the wringer 10 or more times + ((and (list? waitons) + (not (null? waitons)) + (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) + (not (null? (filter + number? + (map (lambda (waiton) + (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run + (not (member waiton reruns))) + 1 + #f)) + waitons))))) ;; could do this more elegantly with a marker.... + (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (hash-table-set! test-registry tfullname 'removed)) + + ;; items is #f then the test is ok to be handed off to launch (but not before) + ;; + ((not items) + (debug:print-info 4 "OUTER COND: (not items)") + (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) + (not (null? tal))) + (loop (car tal)(cdr tal) reg reruns)) + (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap))) + (if loop-list (apply loop loop-list)))) + + ;; items processed into a list but not came in as a list been processed + ;; + ((and (list? items) ;; thus we know our items are already calculated + (not itemdat)) ;; and not yet expanded into the list of things to be done + (debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))") + ;; Must determine if the items list is valid. Discard the test if it is not. + (if (and (list? items) + (> (length items) 0) + (and (list? (car items)) + (> (length (car items)) 0)) + (debug:debug-mode 1)) + (debug:print 2 (map (lambda (row) + (conc (string-intersperse + (map (lambda (varval) + (string-intersperse varval "=")) + row) + " ") + "\n")) + items))) + (for-each + (lambda (my-itemdat) + (let* ((new-test-record (let ((newrec (make-tests:testqueue))) + (vector-copy! test-record newrec) + newrec)) + (my-item-path (item-list->path my-itemdat))) + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (tests:testqueue-set-item_path! new-test-record my-item-path) + (hash-table-set! test-records newtestname new-test-record) + (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath + items) + + ;; (debug:print-info 0 "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items") + + ;; At this point we have possibly added items to tal but all must be handed off to + ;; INNER COND logic. I think loop without rotating the queue + ;; (loop hed tal reg reruns)) + ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test + ;; (loop (car newtal)(cdr newtal) reg reruns) + (if (null? tal) + #f + (loop (car tal)(cdr tal) reg reruns))) + + ;; if items is a proc then need to run items:get-items-from-config, get the list and loop + ;; - but only do that if resources exist to kick off the job + ;; EXPAND ITEMS + ((or (procedure? items)(eq? items 'have-procedure)) + (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs))) + (if (and (list? can-run-more) + (car can-run-more)) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap))) + (if loop-list + (apply loop loop-list))) + ;; if can't run more just loop with next possible test + (loop (car newtal)(cdr newtal) reg reruns)))) + + ;; this case should not happen, added to help catch any bugs + ((and (list? items) itemdat) + (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (exit 1)) + ((not (null? reruns)) + (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (junked (lset-difference equal? tal newlst))) + (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (if (< num-retries max-retries) + (set! newlst (append reruns newlst))) + (set! num-retries (+ num-retries 1)) + ;; (thread-sleep! (+ 1 *global-delta*)) + (if (not (null? newlst)) + ;; since reruns have been tacked on to newlst create new reruns from junked + (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) + ((not (null? tal)) + (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) + ((not (null? reg)) ;; could we get here with leftovers? + (debug:print-info 0 "Have leftovers!") + (loop (car reg)(cdr reg) '() reruns)) + (else + (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + ))) + ;; now *if* -run-wait we wait for all tests to be done + ;; Now wait for any RUNNING tests to complete (if in run-wait mode) + (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (prev-num-running 0)) + ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) + (if (and (or (args:get-arg "-run-wait") + (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) + (> num-running 0)) + (begin + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) + (if (> (current-seconds)(+ last-time-incomplete 900)) + (begin + (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) + (set! last-time-incomplete (current-seconds)) + (rmt:find-and-mark-incomplete run-id #f))) + (if (not (eq? num-running prev-num-running)) + (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) + (thread-sleep! 5) + ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) + (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) + ;; LET* ((test-record + ;; we get here on "drop through". All done! + (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) (equal? (db:test-get-state test) "COMPLETED") (not (member (db:test-get-status test) '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))))) prereqs-not-met)) + +(define (runs:calc-prereq-fail prereqs-not-met) + (filter (lambda (test) + (and (vector? test) ;; not (string? test)) + (equal? (db:test-get-state test) "NOT_STARTED") + (not (member (db:test-get-status test) + '("n/a" "KEEP_TRYING"))))) + prereqs-not-met)) + +(define (runs:calc-not-completed prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (not (equal? "COMPLETED" (db:test-get-state t))))) + prereqs-not-met)) (define (runs:calc-not-completed prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) (not (equal? "COMPLETED" (db:test-get-state t))))) prereqs-not-met)) + +(define (runs:calc-runnable prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (and (equal? "NOT_STARTED" (db:test-get-state t)) + (member (db:test-get-status t) + '("n/a" "KEEP_TRYING"))))) + prereqs-not-met)) (define (runs:pretty-string lst) (map (lambda (t) (if (not (vector? t)) (conc t) @@ -357,326 +1180,89 @@ lst)) (define (runs:make-full-test-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) -;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts) - ;; At this point the list of parent tests is expanded - ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) - (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registery (make-hash-table)) - (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries"))) - (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) - (if (not (null? sorted-test-names)) - (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) - (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) - ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) - (let* ((test-record (hash-table-ref test-records hed)) - (test-name (tests:testqueue-get-testname test-record)) - (tconfig (tests:testqueue-get-testconfig test-record)) - (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) - (if m (string->symbol m) 'normal))) - (waitons (tests:testqueue-get-waitons test-record)) - (priority (tests:testqueue-get-priority test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat)) - (newtal (append tal (list hed)))) - - (debug:print 6 - "test-name: " test-name - "\n hed: " hed - "\n itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons - "\n num-retries: " num-retries - "\n tal: " tal - "\n reruns: " reruns) - - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member test-name waitons) - (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") - (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - - (cond ;; OUTER COND - ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((run-limits-info (open-run-close runs:can-run-more-tests test-record)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup (list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "have-resources: " have-resources " prereqs-not-met: " - (string-intersperse - (map (lambda (t) - (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) - (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) ", ") " fails: " fails) - (debug:print-info 4 "hed=" hed "\n test-record=" test-record "\n test-name: " test-name "\n item-path: " item-path "\n test-patts: " test-patts) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) - (cond ;; INNER COND #1 for a launchable test - ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns))) - ( ;; (and - (not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) - ;; (and max-concurrent-jobs (> (- max-concurrent-jobs num-running) 5))) - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - (open-run-close db:tests-register-test #f run-id test-name item-path) - (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t) - ;; (thread-sleep! *global-delta*) -(runs:shrink-can-run-more-tests-delay) - (loop (car newtal)(cdr newtal) reruns)) - ((not have-resources) ;; simply try again after waiting a second - (debug:print-info 1 "no resources to run new tests, waiting ...") - ;; (thread-sleep! (+ 2 *global-delta*)) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (loop (car newtal)(cdr newtal) reruns)) - ((and have-resources - (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) - (null? non-completed)))) - (run:test run-id runname keyvallst test-record flags #f) -(runs:shrink-can-run-more-tests-delay) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns))) - (else ;; must be we have unmet prerequisites - (debug:print 4 "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - (if (null? fails) - (begin - ;; couldn't run, take a breather - (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient - ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal) reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (not (null? tal)) - (if (vector? hed) - (begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") -(runs:shrink-can-run-more-tests-delay) - ;; (thread-sleep! *global-delta*) - (loop (car tal)(cdr tal) (cons hed reruns))) - (begin - (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") -(runs:shrink-can-run-more-tests-delay) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop hed tal reruns))))))))) ;; END OF INNER COND - - ;; case where an items came in as a list been processed - ((and (list? items) ;; thus we know our items are already calculated - (not itemdat)) ;; and not yet expanded into the list of things to be done - (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) - (> (length items) 0) - (> (length (car items)) 0)) - (pp items)) - (for-each - (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath - items) - (if (not (null? tal)) - (begin - (debug:print-info 4 "End of items list, looping with next after short delay") - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop (car tal)(cdr tal) reruns)))) - - ;; if items is a proc then need to run items:get-items-from-config, get the list and loop - ;; - but only do that if resources exist to kick off the job - ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests test-record))) - (if (and (list? can-run-more) - (car can-run-more)) - (let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "can-run-more: " can-run-more - "\n testname: " hed - "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) - "\n non-completed: " (runs:pretty-string non-completed) - "\n fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n num-retries: " num-retries - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (cond ;; INNER COND #2 - ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - (and (eq? testmode 'toplevel) - (null? non-completed))) - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (tests:testqueue-set-items! test-record items-list) - ;; (thread-sleep! *global-delta*) - (loop hed tal reruns)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))))) - ((null? fails) - (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") - ;; only increment num-retries when there are no tests runing - (if (eq? 0 (list-ref can-run-more 1)) - (begin - (if (> num-retries 100) ;; first 100 retries are low time cost - (thread-sleep! (+ 2 *global-delta*)) - (thread-sleep! (+ 0.01 *global-delta*))) - (set! num-retries (+ num-retries 1)))) - (if (> num-retries max-retries) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns)) - (loop (car newtal)(cdr newtal) reruns))) ;; an issue with prereqs not yet met? - ((and (not (null? fails))(eq? testmode 'normal)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (if (not (null? tal)) - (begin - ;; (thread-sleep! *global-delta*) - (loop (car tal)(cdr tal)(cons hed reruns))))) - (else - (debug:print 8 "ERROR: No handler for this condition.") - (thread-sleep! (+ 1 *global-delta*)) - (loop (car newtal)(cdr newtal) reruns)))) ;; END OF IF CAN RUN MORE - - ;; if can't run more just loop with next possible test - (begin - (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) - ;; (thread-sleep! (+ 2 *global-delta*)) - (loop (car newtal)(cdr newtal) reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) - - ;; this case should not happen, added to help catch any bugs - ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)) - ((not (null? reruns)) - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) - (if (< num-retries max-retries) - (set! newlst (append reruns newlst))) - (set! num-retries (+ num-retries 1)) - ;; (thread-sleep! (+ 1 *global-delta*)) - (if (not (null? newlst)) - ;; since reruns have been tacked on to newlst create new reruns from junked - (loop (car newlst)(cdr newlst)(delete-duplicates junked))))) - ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) - (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - )))) ;; LET* ((test-record - - ;; we get here on "drop through" - loop for next test in queue - ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - - (debug:print-info 1 "All tests launched") - (thread-sleep! 0.5) - ;; FIXME! This harsh exit should not be necessary.... - ;; (if (not *runremote*)(exit)) ;; - #f)) ;; return a #f as a hint that we are done - ;; Here we need to check that all the tests remaining to be run are eligible to run - ;; and are not blocked by failed - - ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test run-id runname keyvallst test-record flags parent-test) +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) - (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) + (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) (item-path "") - (db #f)) - (debug:print 4 - "test-config: " (hash-table->alist test-conf) - "\n itemdat: " itemdat - ) + (db #f) + (full-test-name #f)) + ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) - (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) + (set! full-test-name (runs:make-full-test-name test-name item-path)) + (debug:print-info 4 + "\nTESTNAME: " full-test-name + "\n test-config: " (hash-table->alist test-conf) + "\n itemdat: " itemdat + ) + (debug:print 2 "Attempting to launch test " full-test-name) (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_ITEMPATH" item-path) (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? + ;; + ;; There is now a single call to runs:update-all-test_meta and this + ;; per-test call is not needed. Given the delicacy of the move to + ;; v1.55 this code is being left in place for the time being. + ;; (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) - (open-run-close runs:update-test_meta db test-name test-conf))) + (runs:update-test_meta test-name test-conf))) - ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) + ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (rmt:get-test-id run-id test-name item-path)) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) (if (not testdat) - (begin + (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (open-run-close db:tests-register-test #f run-id test-name item-path) - (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) + (rmt:general-call 'register-test run-id run-id test-name item-path) + (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (cdb:get-test-info-by-id *runremote* test-id)))) + (set! testdat (rmt:get-test-info-by-id run-id test-id)) + (if (not testdat) + (begin + (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") + (thread-sleep! 1) + (loop))))) + (if (not testdat) ;; should NOT happen + (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) - (change-directory test-path) + (if (file-exists? test-path) + (change-directory test-path) + (begin + (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") + (change-directory *toppath*))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) @@ -691,13 +1277,14 @@ ((member (test:get-state testdat) '("DELETED" "NOT_STARTED"))(set! runflag #t)) ;; not -rerun and PASS, WARN or CHECK, do no run ((and (or (not rerun) keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK - (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP")) + (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) (member (test:get-state testdat) '("COMPLETED")))) (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) (set! runflag #f)) ;; -rerun and status is one of the specifed, run it ((and rerun (let* ((rerunlst (string-split rerun ",")) (must-rerun (member (test:get-status testdat) rerunlst))) @@ -711,34 +1298,66 @@ (set! runflag #f)) ((and (not rerun) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) - (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) - "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) - "\" or -force to override")) + (if (runs:lownoise (conc "not starting test" full-test-name) 60) + (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) + "\" or -force to override"))) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. - (if (not (launch-test #f run-id runname test-conf keyvallst test-name test-path itemdat flags)) - (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill)))))) + ;; This would be a great place to do the process-fork + ;; + (let ((skip-test #f) + (skip-check (configf:get-section test-conf "skip"))) + (cond + ;; Have to check for skip conditions. This one skips if there are same-named tests + ;; currently running + ((and skip-check + (configf:lookup test-conf "skip" "prevrunning")) + ;; run-ids = #f means *all* runs + (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (if (not (null? running-tests)) ;; have to skip + (set! skip-test "Skipping due to previous tests running")))) + ((and skip-check + (configf:lookup test-conf "skip" "fileexists")) + (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) + (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) + (if skip-test + (begin + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) + (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) + (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) + (begin + (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill)))))))) ((KILLED) - (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") + (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) - (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - (db:test-get-run_duration testdat))) - 600) ;; i.e. no update for more than 600 seconds - (begin - (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) - (debug:print 2 "NOTE: " test-name " is already running"))) - (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) + (debug:print 2 "NOTE: " test-name " is already running")) + ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; (or incomplete-timeout + ;; 6000)) ;; i.e. no update for more than 6000 seconds + ;; (begin + ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; (debug:print 2 "NOTE: " test-name " is already running"))) + (else + (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (case (string->symbol (test:get-state testdat)) + ((COMPLETED INCOMPLETE) + (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) + (else + (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)))))))) ;;====================================================================== ;; END OF NEW STUFF ;;====================================================================== @@ -746,23 +1365,52 @@ (let ((dparts (string-split dir "/")) (count (if (null? params) 1 (car params)))) (conc "/" (string-intersperse (take dparts (- (length dparts) count)) "/")))) + +(define (runs:recursive-delete-with-error-msg real-dir) + (if (> (system (conc "rm -rf " real-dir)) 0) + (begin + ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time + (system (conc "chmod -R a+rwx " real-dir)) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))))) + +(define (runs:safe-delete-test-dir real-dir) + ;; first delete all sub-directories + (directory-fold + (lambda (f x) + (let ((fullname (conc real-dir "/" f))) + (if (directory? fullname)(runs:recursive-delete-with-error-msg fullname))) + (+ 1 x)) + 0 real-dir) + ;; then files other than *testdat.db* + (directory-fold + (lambda (f x) + (let ((fullname (conc real-dir "/" f))) + (if (not (string-search (regexp "testdat.db") f)) + (runs:recursive-delete-with-error-msg fullname))) + (+ 1 x)) + 0 real-dir) + ;; then the entire directory + (runs:recursive-delete-with-error-msg real-dir)) + ;; Remove runs ;; fields are passing in through ;; action: ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) - (keys (open-run-close db:get-keys db)) - (rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt)) + (tdbdat (tasks:open-db)) + (keys (rmt:get-keys)) + (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))) @@ -772,152 +1420,229 @@ (debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) - (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) - (dirs-to-remove (make-hash-table))) + (db:get-value-by-header run header k)) keys) "/")) + (dirs-to-remove (make-hash-table)) + (proc-get-tests (lambda (run-id) + (mt:get-tests-for-run run-id + testpatt states statuses + not-in: #f + sort-by: (case action + ((remove-runs) 'rundir) + (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) + (run-name (db:get-value-by-header run header "runname")) (tests (if (not (equal? run-state "locked")) - (open-run-close db:get-tests-for-run db run-id - testpatt states statuses - not-in: #f - sort-by: (case action - ((remove-runs) 'rundir) - (else 'event_time))) + (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope")) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) + (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + ;; seek and kill in flight -runtests with % as testpatt here + (if (equal? testpatt "%") + (tasks:kill-runner (db:delay-if-busy tdbdat) target run-name) + (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) + (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) + ((run-wait) + (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) - (for-each - (lambda (test) - (let* ((item-path (db:test-get-item-path test)) - (test-name (db:test-get-testname test)) - (run-dir (db:test-get-rundir test)) ;; run dir is from the link tree - (real-dir (if (file-exists? run-dir) - (resolve-pathname run-dir) - #f)) - (test-id (db:test-get-id test))) - ;; (tdb (db:open-test-db run-dir))) - (debug:print-info 4 "test=" test) ;; " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) - (case action - ((remove-runs) ;; the tdb is for future possible. - (open-run-close db:delete-test-records db #f (db:test-get-id test)) - (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) - (if (and real-dir - (> (string-length real-dir) 5) - (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (begin ;; let* ((realpath (resolve-pathname run-dir))) - (debug:print-info 1 "Recursively removing " real-dir) - (if (file-exists? real-dir) - (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f")) - (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) - (if real-dir - (debug:print 0 "WARNING: directory " real-dir " does not exist") - (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) - (if (symbolic-link? run-dir) - (begin - (debug:print-info 1 "Removing symlink " run-dir) - (handle-exceptions - exn - (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") - (delete-file run-dir))) - (if (directory? run-dir) - (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") - (handle-exceptions - exn - (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") - (delete-directory run-dir))) - (if run-dir - (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") - (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) - ))) - ((set-state-status) - (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) - (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) - (dirb (db:test-get-rundir b))) - (if (and (string? dira)(string? dirb)) - (> (string-length dira)(string-length dirb)) - #f))))))) + (let ((sorted-tests (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) + (dirb ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) + (if (and (string? dira)(string? dirb)) + (> (string-length dira)(string-length dirb)) + #f))))) + (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests + (test-retry-time (make-hash-table)) + (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em + (let loop ((test (car sorted-tests)) + (tal (cdr sorted-tests))) + (let* ((test-id (db:test-get-id test)) + (new-test-dat (rmt:get-test-info-by-id run-id test-id))) + (if (not new-test-dat) + (begin + (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + (let* ((item-path (db:test-get-item-path new-test-dat)) + (test-name (db:test-get-testname new-test-dat)) + (run-dir ;;(filedb:get-path *fdb* + ;; (rmt:sdb-qry 'getid + (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree + (test-state (db:test-get-state new-test-dat)) + (test-fulln (db:test-get-fullname new-test-dat)) + (uname (db:test-get-uname new-test-dat)) + (toplevel-with-children (and (db:test-get-is-toplevel test) + (> (rmt:test-toplevel-num-items run-id test-name) 0)))) + (case action + ((remove-runs) + ;; if the test is a toplevel-with-children issue an error and do not remove + (if toplevel-with-children + (begin + (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) + (if (> (hash-table-ref toplevel-retries test-fulln) 3) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue + (begin + (debug:print-info 0 "test: " test-name " itest-state: " test-state) + (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (begin + (if (not (hash-table-ref/default test-retry-time test-fulln #f)) + (begin + ;; want to set to REMOVING BUT CANNOT do it here? + (hash-table-set! test-retry-time test-fulln (current-seconds)))) + (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) + ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first + ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give + ;; up and blow it away. + (begin + (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (thread-sleep! 1)) + (begin + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (thread-sleep! 1))) + ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... + (if (null? tal) + (loop new-test-dat tal) + (loop (car tal)(append tal (list new-test-dat))))) + (begin + (runs:remove-test-directory db new-test-dat remove-data-only) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))))))) + ((set-state-status) + (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + ((run-wait) + (debug:print-info 2 "still waiting, " (length tests) " tests still running") + (thread-sleep! 10) + (let ((new-tests (proc-get-tests run-id))) + (if (null? new-tests) + (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") + (loop (car new-tests)(cdr new-tests)))))))) + ))))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) - (let ((remtests (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) + (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (open-run-close db:delete-run db run-id) - ;; This is a pretty good place to purge old DELETED tests - (open-run-close db:delete-tests-for-run db run-id) - (open-run-close db:delete-old-deleted-test-records db) - (open-run-close db:set-var db "DELETED_TESTS" (current-seconds)) + (rmt:delete-run run-id) + (rmt:delete-old-deleted-test-records) + ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) - runs)) + runs) + ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) + ) #t) +(define (runs:remove-test-directory db test remove-data-only) + (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree + (real-dir (if (file-exists? run-dir) + (resolve-pathname run-dir) + #f))) + (if remove-data-only + (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f) + (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) + (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) + (if (and real-dir + (> (string-length real-dir) 5) + (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (begin ;; let* ((realpath (resolve-pathname run-dir))) + (debug:print-info 1 "Recursively removing " real-dir) + (if (file-exists? real-dir) + (runs:safe-delete-test-dir real-dir) + (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) + (if real-dir + (debug:print 0 "WARNING: directory " real-dir " does not exist") + (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) + (if (symbolic-link? run-dir) + (begin + (debug:print-info 1 "Removing symlink " run-dir) + (handle-exceptions + exn + (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (delete-file run-dir))) + (if (directory? run-dir) + (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) + (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (handle-exceptions + exn + (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (delete-directory run-dir))) + (if (and run-dir + (not (member run-dir (list "n/a" "/tmp/badname")))) + (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) + )) + ;; Only delete the records *after* removing the directory. If things fail we have a record + (if remove-data-only + (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f) + (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))) + ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) - (let ((runname (args:get-arg ":runname")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - (args:get-arg "-reqtarg"))) - (th1 #f)) + (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (target (common:args-get-target))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") + (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else (let ((db #f) (keys #f)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (if (args:get-arg "-server") - (open-run-close server:start db (args:get-arg "-server"))) - ;; (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers - ;; (args:get-arg "-runtests"))) - ;; (client:setup) ;; This is a duplicate startup!!!??? BUG? - ;; )) - (set! keys (open-run-close db:get-keys db)) + ;; (if (args:get-arg "-server") + ;; (cdb:remote-run server:start db (args:get-arg "-server"))) + (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL - (runconfig (read-config runconfigf #f #t environ-patt: #f))) + (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) + (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) (exit 1)))) (if (args:get-arg "-target") @@ -926,82 +1651,78 @@ (begin (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc - (let* ((keynames (map key:get-fieldname keys)) - (keyvallst (keys->vallist keys #t))) - (proc target runname keys keynames keyvallst))) - (if th1 (thread-join! th1)) + (let* ((keyvals (keys:target->keyval keys target))) + (proc target runname keys keyvals))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))))) ;;====================================================================== ;; Lock/unlock runs ;;====================================================================== (define (runs:handle-locking target keys runname lock unlock user) (let* ((db #f) - (rundat (open-run-close runs:get-runs-by-patt db keys runname)) + (rundat (mt:get-runs-by-patt keys runname target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (open-run-close db:lock/unlock-run db run-id lock unlock user) + (rmt:lock/unlock-run run-id lock unlock user) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test -(define (runs:update-test_meta db test-name test-conf) - (let ((currrecord (open-run-close db:testmeta-get-record db test-name))) +(define (runs:update-test_meta test-name test-conf) + (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin - (set! currrecord (make-vector 10 #f)) - (open-run-close db:testmeta-add-record db test-name))) + (set! currrecord (make-vector 11 #f)) + (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (open-run-close db:testmeta-update-field db test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) + (rmt:testmeta-update-field test-name fld val))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (get-all-legal-tests))) + (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) - (let* ((test-path (conc *toppath* "/tests/" test-name)) - (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) - ;; read configs with tricks turned off (i.e. no system) - (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) - ;; use the open-run-close instead of passing in db - (runs:update-test_meta #f test-name test-conf))) - test-names))) + (let* ((test-conf (mt:lazy-read-test-config test-name))) + (if test-conf (runs:update-test_meta test-name test-conf)))) + (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... -(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst - (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) - (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) - (new-run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) - (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) - (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '())) +;; NOT PORTED - DO NOT USE YET +;; +(define (runs:rollup-run keys runname user keyvals) + (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user) + (let* ((db #f) + ;; register run operates on the main db + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) + (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) + (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) - (open-run-close db:update-run-event_time db new-run-id) + (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -1015,23 +1736,23 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (open-run-close db:get-steps-for-test db (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) - (set! new-testdat (car (open-run-close db:get-tests-for-run db new-run-id (conc testname "/" item-path) '() '()))) + (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (open-run-close + (cdb:remote-run (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") ADDED sdb.scm Index: sdb.scm ================================================================== --- /dev/null +++ sdb.scm @@ -0,0 +1,107 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + +;; +(define (sdb:open fname) + (let* ((dbpath (pathname-directory fname)) + (dbexists (let ((fe (file-exists? fname))) + (if fe + fe + (begin + (create-directory dbpath #t) + #f)))) + (sdb (sqlite3:open-database fname)) + (handler (make-busy-timeout 136000))) + (sqlite3:set-busy-handler! sdb handler) + (if (not dbexists) + (sdb:initialize sdb)) + (sqlite3:execute sdb "PRAGMA synchronous = 1;") + sdb)) + +(define (sdb:initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (sdb:register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (sdb:string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (sdb:id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +;; Numbers get passed though in both directions +;; +(define (make-sdb:qry fname) + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (case cmd + ((setup) (set! sdb (if (not sdb) + (sdb:open (if var var fname))))) + ((setdb) (set! sdb var)) + ((getdb) sdb) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (sdb:string->id sdb scache var)))) + (if id + id + (begin + (sdb:register-string sdb var) + (sdb:string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (sdb:id->string sdb icache var) + var)) + ((passid) var) + ((passstr) var) + (else #f))))) + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils) ;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -20,10 +20,11 @@ (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses synchash)) (declare (uses http-transport)) +(declare (uses launch)) ;; (declare (uses zmq-transport)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") @@ -42,54 +43,23 @@ ;; Call this to start the actual server ;; ;; all routes though here end in exit ... -(define (server:launch transport) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting server using " transport " transport") - (set! *transport-type* transport) - (case transport - ((fs) (exit)) ;; there is no "fs" transport - ((http) (http-transport:launch)) - ((zmq) (zmq-transport:launch)) - (else - (debug:print "WARNING: unrecognised transport " transport) - (exit)))) +;; +;; start_server +;; +(define (server:launch run-id) + (http-transport:launch run-id)) ;;====================================================================== ;; Q U E U E M A N A G E M E N T ;;====================================================================== ;; We don't want to flush the queue if it was just flushed (define *server:last-write-flush* (current-milliseconds)) -;; Flush the queue every third of a second. Can we assume that setup-for-run -;; has already been done? -(define (server:write-queue-handler) - (if (setup-for-run) - (let ((db (open-db))) - (let loop () - (let ((last-write-flush-time #f)) - (mutex-lock! *incoming-mutex*) - (set! last-write-flush-time *server:last-write-flush*) - (mutex-unlock! *incoming-mutex*) - (if (> (- (current-milliseconds) last-write-flush-time) 10) - (begin - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*) - (thread-sleep! 0.005)))) - (loop))) - (begin - (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") - (exit 1)))) - ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Generate a unique signature for this server @@ -103,19 +73,128 @@ ;; When using zmq this would send the message back (two step process) ;; with spiffy or rpc this simply returns the return data to be returned ;; (define (server:reply return-addr query-sig success/fail result) - (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result) - ;; (send-message pubsock target send-more: #t) - ;; (send-message pubsock - (case *transport-type* - ((fs) result) - ((http)(db:obj->string (vector success/fail query-sig result))) - ((zmq) - (let ((pub-socket (vector-ref *runremote* 1))) - (send-message pub-socket return-addr send-more: #t) - (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) - (else - (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) - result))) - + (db:obj->string (vector success/fail query-sig result))) + +;; Given a run id start a server process ### NOTE ### > file 2>&1 +;; if the run-id is zero and the target-host is set +;; try running on that host +;; +(define (server:run run-id) + (let* ((curr-host (get-host-name)) + (curr-ip (server:get-best-guess-address curr-host)) + (target-host (configf:lookup *configdat* "server" "homehost" )) + (testsuite (common:get-testsuite-name)) + (logfile (conc *toppath* "/logs/" run-id ".log")) + (cmdln (conc (common:get-megatest-exe) + " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") + (conc " -daemonize -log " logfile) + "") + " -debug 4 testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) + (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") + (push-directory *toppath*) + (if (not (directory-exists? "logs"))(create-directory "logs")) + ;; host.domain.tld match host? + (if (and target-host + ;; look at target host, is it host.domain.tld or ip address and does it + ;; match current ip or hostname + (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) + (not (equal? curr-ip target-host))) + (begin + (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile) + (setenv "TARGETHOST" target-host))) + (setenv "TARGETHOST_LOGF" logfile) + (system (conc "nbfake " cmdln)) + (unsetenv "TARGETHOST_LOGF") + (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) + ;; (system cmdln) + (pop-directory))) + +;; kind start up of servers, wait 40 seconds before allowing another server for a given +;; run-id to be launched +(define (server:kind-run run-id) + (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f))) + (if (or (not last-run-time) + (> (- (current-seconds) last-run-time) 30)) + (begin + (server:run run-id) + (hash-table-set! *server-kind-run* run-id (current-seconds)))))) + +;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 +;; +(define (server:try-running run-id) + (if (eq? run-id 0) + (server:run run-id) + (rmt:start-server run-id))) + +(define (server:check-if-running run-id) + (let ((tdbdat (tasks:open-db))) + (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id)) + (trycount 0)) + (if server + ;; note: client:start will set *runremote*. this needs to be changed + ;; also, client:start will login to the server, also need to change that. + ;; + ;; client:start returns #t if login was successful. + ;; + (let ((res (server:ping-server run-id + (tasks:hostinfo-get-interface server) + (tasks:hostinfo-get-port server)))) + ;; if the server didn't respond we must remove the record + (if res + #t + (begin + (debug:print-info 0 "server at " server " not responding, removing record") + (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id + " server:check-if-running") + res))) + #f)))) + +;; called in megatest.scm, host-port is string hostname:port +;; +(define (server:ping run-id host:port) + (let ((tdbdat (tasks:open-db))) + (let* ((host-port (let ((slst (string-split host:port ":"))) + (if (eq? (length slst) 2) + (list (car slst)(string->number (cadr slst))) + #f))) + (toppath (launch:setup-for-run)) + (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) + (if (not run-id) + (begin + (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") + (print "ERROR: No run-id") + (exit 1)) + (if (and (not host-port) + (not server-db-dat)) + (begin + (print "ERROR: bad host:port") + (exit 1)) + (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat))) + (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat))) + (server-dat (http-transport:client-connect iface port)) + (login-res (rmt:login-no-auto-client-setup server-dat run-id))) + (if (and (list? login-res) + (car login-res)) + (begin + (print "LOGIN_OK") + (exit 0)) + (begin + (print "LOGIN_FAILED") + (exit 1))))))))) + +;; run ping in separate process, safest way in some cases +;; +(define (server:ping-server run-id iface port) + (with-input-from-pipe + (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port)) + (lambda () + (let loop ((inl (read-line)) + (res "NOREPLY")) + (if (eof-object? inl) + (case (string->symbol res) + ((NOREPLY) #f) + ((LOGIN_OK) #t) + (else #f)) + (loop (read-line) inl)))))) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -12,11 +12,12 @@ ;;====================================================================== ;; A hash of hashes that can be kept in sync by sending minial deltas ;;====================================================================== (use format) -(use srfi-1 srfi-69) +(use srfi-1 srfi-69 sqlite3) +(import (prefix sqlite3 sqlite3:)) (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (include "db_records.scm") @@ -62,11 +63,12 @@ ;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) - (let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) + (let* ((data ;; (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) + (apply synchash:server-get #f proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) (begin @@ -87,13 +89,14 @@ ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) -(define (synchash:server-get db proc synckey keynum . params) +(define (synchash:server-get indb proc synckey keynum . params) ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) - (let* ((synchash (hash-table-ref/default *synchashes* synckey #f)) + (let* ((db (if indb indb (db:open-megatest-db))) + (synchash (hash-table-ref/default *synchashes* synckey #f)) (newdat (apply (case proc ((db:get-runs) db:get-runs) ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata) ((db:get-test-info-by-ids) db:get-test-info-by-ids) (else @@ -114,11 +117,12 @@ (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) + ;; (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -20,39 +20,112 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== -(define (tasks:open-db) - (let* ((dbpath (conc *toppath* "/monitor.db")) - (exists (file-exists? dbpath)) - (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) - (sqlite3:set-busy-handler! mdb handler) - (sqlite3:execute mdb (conc "PRAGMA synchronous = 1;")) - (if (not exists) - (begin - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, +;; wait up to aprox n seconds for a journal to go away +;; +(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) + (if (not (string? path)) + (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") + (let ((fullpath (conc path "-journal"))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " exn=" (condition->list exn)) + (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + #t) ;; if stuff goes wrong just allow it to move on + (let loop ((journal-exists (file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (begin + (if (and waiting-msg + (eq? (modulo n 30) 0)) + (debug:print 0 waiting-msg)) + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (file-exists? fullpath) + (- count 1))) + (begin + (if remove (system (conc "rm -rf " fullpath))) + #f))) + #t)))))) + +(define (tasks:get-task-db-path) + (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) + (dbpath (conc linktree "/.db"))) + dbpath)) + + + +;; If file exists AND +;; file readable +;; ==> open it +;; If file exists AND +;; file NOT readable +;; ==> open in-mem version +;; If file NOT exists +;; ==> open in-mem version +;; +(define (tasks:open-db #!key (numretries 4)) + (if *task-db* + *task-db* + (handle-exceptions + exn + (if (> numretries 0) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " exn=" (condition->list exn)) + (thread-sleep! 1) + (tasks:open-db numretries (- numretries 1))) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " exn=" (condition->list exn)))) + (let* ((dbpath (tasks:get-task-db-path)) + (dbfile (conc dbpath "/monitor.db")) + (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away + (exists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (mdb (cond ;; what the hek is *toppath* doing here? + ((and (string? *toppath*)(file-write-access? *toppath*)) + (sqlite3:open-database dbfile)) + ((file-read-access? dbpath) (sqlite3:open-database dbfile)) + (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 36000))) + (if (and exists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control + (sqlite3:set-busy-handler! mdb handler) + (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) + ;; (if (or (and (not exists) + ;; (file-write-access? *toppath*)) + ;; (not (file-read-access? dbpath))) + ;; (begin + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', - test TEXT DEFAULT '', - item TEXT DEFAULT '', + testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP, execution_time TIMESTAMP);") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, pid INTEGER, interface TEXT, hostname TEXT, port INTEGER, pubport INTEGER, @@ -60,23 +133,26 @@ priority INTEGER, state TEXT, mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, - CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, + run_id INTEGER);") + ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") + (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") - - )) - mdb)) - + + ;)) + (sqlite3:execute mdb "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (set! *task-db* (cons mdb dbpath)) + *task-db*)))) + ;;====================================================================== ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname @@ -86,202 +162,270 @@ (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) (define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) (define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) (define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) -;; state: 'live, 'shutting-down, 'dead -(define (tasks:server-register mdb pid interface port priority state transport #!key (pubport -1)) - (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state) +(define (tasks:server-lock-slot mdb run-id) + (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot") + (if (< (tasks:num-in-available-state mdb run-id) 4) + (begin + (tasks:server-set-available mdb run-id) + ;; (thread-sleep! 2) ;; Try removing this. It may not be needed. + (tasks:server-am-i-the-server? mdb run-id)) + #f)) + +;; register that this server may come online (first to register goes though with the process) +(define (tasks:server-set-available mdb run-id) (sqlite3:execute mdb - "INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport) - VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);" - pid (get-host-name) port pubport priority (conc state) megatest-version interface (conc transport)) - (vector - (tasks:server-get-server-id mdb (get-host-name) interface port pid) - interface - port - pubport - transport + "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id) + VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);" + (current-process-id) ;; pid + (get-host-name) ;; hostname + -1 ;; port + -1 ;; pubport + (random 1000) ;; priority (used a tiebreaker on get-available) + "available" ;; state + (common:version-signature) ;; mt_version + -1 ;; interface + "http" ;; transport + run-id )) -;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used! -(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'markdead)) - (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid) - (if pid - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) - (if port - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port))) - (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))) - -(define (tasks:server-deregister-self mdb hostname) - (tasks:server-deregister mdb hostname pid: (current-process-id))) - -;; need a simple call for robustly removing records given host and port -(define (tasks:server-delete mdb hostname port) - (tasks:server-deregister mdb hostname port: port action: 'delete)) - -(define (tasks:server-get-server-id mdb hostname iface port pid) - (debug:print-info 12 "tasks:server-get-server-id " mdb " " hostname " " iface " " port " " pid) +(define (tasks:num-in-available-state mdb run-id) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-in-queue) + (set! res num-in-queue)) + mdb + "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available' AND (strftime('%s','now') - start_time) < 30 ;" + run-id) + res)) + +(define (tasks:num-servers-non-zero-running mdb) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-running) + (set! res num-running)) + mdb + "SELECT count(id) FROM servers WHERE run_id != 0 AND state = 'running';") + res)) + +(define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;" + (conc "defunct" tag) run-id)) + +(define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;" + (conc "defunct" tag) run-id)) + +(define (tasks:server-force-clean-run-record mdb run-id iface port tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;" + (conc "defunct" tag) run-id iface port)) + +(define (tasks:server-delete-records-for-this-pid mdb tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" + (conc "defunct" tag) (get-host-name) (current-process-id))) + +(define (tasks:server-delete-record mdb server-id tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" + (conc "defunct" tag) server-id) + ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder) + (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;") + (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;") + ) + +(define (tasks:server-set-state! mdb server-id state) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id)) + +(define (tasks:server-set-interface-port mdb server-id interface port) + (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id)) + +;; Get random port not used in long time +;; +(define (tasks:server-get-next-port mdb) + (let* ((lownum 30000) + (highnum 64000) + (used-ports '()) + (get-rand-port (lambda () + (+ lownum (random (- highnum lownum))))) + (port-param (if (and (args:get-arg "-port") + (string->number (args:get-arg "-port"))) + (string->number (args:get-arg "-port")) + #f)) + ;; (config-port (if (and (config-lookup *configdat* "server" "port") + ;; (string->number (config-lookup *configdat* "server" "port"))) + ;; (string->number (config-lookup *configdat* "server" "port")) + ;; #f)) + ) + (sqlite3:for-each-row + (lambda (port) + (set! used-ports (cons port used-ports))) + mdb + "SELECT port FROM servers;") + (cond + ((and port-param res) (if (> res port-param) res port-param)) + (port-param port-param) + ;; ((and config-port res) (if (> res config-port) res config-port)) + ;; (config-port config-port) + (else + (let loop ((port (get-rand-port)) + (remtries 100)) + (if (member port used-ports) + (if (> remtries 0) + (loop (get-rand-port)(- remtries 1)) + (get-rand-port)) + port)))))) + +(define (tasks:server-am-i-the-server? mdb run-id) + (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id)) + (first (if (null? all) + (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.") + (sqlite3:finalize! mdb) + (exit 1)) + (car (db:get-rows all)))) + (header (db:get-header all)) + (id (db:get-value-by-header first header "id")) + (hostname (db:get-value-by-header first header "hostname")) + (pid (db:get-value-by-header first header "pid")) + (priority (db:get-value-by-header first header "priority"))) + (debug:print 0 "INFO: am-i-the-server got record " first) + ;; for now a basic check. add tiebreaking by priority later + (if (and (equal? hostname (get-host-name)) + (equal? pid (current-process-id))) + id + #f))) + +;; Use: (db:get-value-by-header (car (db:get-rows dat)) (db:get-header dat) "fieldname") +;; to extract info from the structure returned +;; +(define (tasks:server-get-servers-vying-for-run-id mdb run-id) + (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time")) + (selstr (string-intersperse header ",")) + (res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (apply vector a b) res))) + mdb + (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") + run-id) + (vector header res))) + +(define (tasks:get-server mdb run-id #!key (retries 10)) + (let ((res #f) + (best #f)) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 "WARNING: tasks:get-server db access error.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 " for run " run-id) + (print-call-chain (current-error-port)) + (if (> retries 0) + (begin + (debug:print 0 " trying call to tasks:get-server again in 10 seconds") + (thread-sleep! 10) + (tasks:get-server mdb run-id retries: (- retries 0))) + (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) + (sqlite3:for-each-row + (lambda (id interface port pubport transport pid hostname) + (set! res (vector id interface port pubport transport pid hostname))) + mdb + ;; removed: + ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? + "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers + WHERE run_id=? AND state='running' + ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) + res))) + +(define (tasks:server-running-or-starting? mdb run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (id) + (set! res id)) + mdb ;; NEEDS dbprep ADDED + "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id) + res)) + +(define (tasks:server-running? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) - mdb - (cond - ((and hostname pid) "SELECT id FROM servers WHERE hostname=? AND pid=?;") - ((and iface port) "SELECT id FROM servers WHERE interface=? AND port=?;") - ((and hostname port) "SELECT id FROM servers WHERE hostname=? AND port=?;") - (else - (begin - (debug:print 0 "ERROR: tasks:server-get-server-id needs (hostname and pid) OR (iface and port) OR (hostname and port)") - "SELECT id FROM servers WHERE pid=-999;"))) - (if hostname hostname iface)(if pid pid port)) + mdb ;; NEEDS dbprep ADDED + "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) -(define (tasks:server-update-heartbeat mdb server-id) - (debug:print-info 0 "Heart beat update of server id=" server-id) - (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id)) - -;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds -(define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f)) - (let* ((server-id (if server-id - server-id - (tasks:server-get-server-id mdb hostname iface port pid))) - (heartbeat-delta 99e9)) - (sqlite3:for-each-row - (lambda (delta) - (set! heartbeat-delta delta)) - mdb "SELECT strftime('%s','now')-heartbeat FROM servers WHERE id=?;" server-id) - (< heartbeat-delta 10))) - -(define (tasks:client-register mdb pid hostname cmdline) - (sqlite3:execute - mdb - "INSERT OR REPLACE INTO clients (server_id,pid,hostname,cmdline,login_time) VALUES(?,?,?,?,strftime('%s','now'));") - (tasks:server-get-server-id mdb hostname #f #f pid) - pid hostname cmdline) - -(define (tasks:client-logout mdb pid hostname cmdline) - (sqlite3:execute - mdb - "UPDATE clients SET logout_time=strftime('%s','now') WHERE pid=? AND hostname=? AND cmdline=?;" - pid hostname cmdline)) - -(define (tasks:get-logged-in-clients mdb server-id) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id server-id pid hostname cmdline login-time logout-time) - (set! res (cons (vector id server-id pid hostname cmdline login-time lougout-time) res))) - mdb - "SELECT id,server_id,pid,hostname,cmdline,login_time,logout_time FROM clients WHERE server_id=?;" - server-id))) - -(define (tasks:have-clients? mdb server-id) - (null? (tasks:get-logged-in-clients mdb server-id))) - -;; ping each server in the db and return first found that responds. -;; remove any others. will not necessarily remove all! -(define (tasks:get-best-server mdb) - (let ((res '()) - (best #f)) - (sqlite3:for-each-row - (lambda (id interface port pubport transport pid hostname) - (set! res (cons (vector id interface port pubport transport pid hostname) res)) - ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) - ) - mdb - - "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers - WHERE strftime('%s','now')-heartbeat < 10 - AND mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version) - ;; for now we are keeping only one server registered in the db, return #f or first server found - (if (null? res) #f (car res)))) - -;; BUG: This logic is probably needed unless methodology changes completely... +(define (tasks:need-server run-id) + (let ((forced (configf:lookup *configdat* "server" "required")) + (maxqry (cdr (rmt:get-max-query-average run-id))) + (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) + (cond + (forced + (if (common:low-noise-print 60 run-id "server required is set") + (debug:print-info 0 "Server required is set, starting server.")) + #t) + ((> maxqry threshold) + (if (common:low-noise-print 60 run-id "Max query time execeeded") + (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, starting server.")) + #t) + (else + #f)))) + +;; try to start a server and wait for it to be available ;; -;; (if (null? res) #f -;; (let loop ((hed (car res)) -;; (tal (cdr res))) -;; ;; (print "hed=" hed ", tal=" tal) -;; (let* ((host (list-ref hed 0)) -;; (iface (list-ref hed 1)) -;; (port (list-ref hed 2)) -;; (pid (list-ref hed 4)) -;; (alive (open-run-close tasks:server-alive? tasks:open-db #f hostname: host port: port))) -;; (if alive -;; (begin -;; (debug:print-info 2 "Found an existing, alive, server " host ", " port ".") -;; (list host iface port)) -;; (begin -;; (debug:print-info 1 "Marking " host ":" port " as dead in server registry.") -;; (if port -;; (open-run-close tasks:server-deregister tasks:open-db host port: port) -;; (open-run-close tasks:server-deregister tasks:open-db host pid: pid)) -;; (if (null? tal) -;; #f -;; (loop (car tal)(cdr tal)))))))))) - -(define (tasks:remove-server-records mdb) - (sqlite3:execute mdb "DELETE FROM servers;")) - -(define (tasks:mark-server hostname port pid state transport) - (if port - (open-run-close tasks:server-deregister tasks:open-db hostname port: port) - (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid))) - - -(define (tasks:kill-server status hostname port pid transport) - (debug:print-info 1 "Removing defunct server record for " hostname ":" port) - (if port - (open-run-close tasks:server-deregister tasks:open-db hostname port: port) - (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)) - (if status ;; #t means alive - (begin - (if (equal? hostname (get-host-name)) - (handle-exceptions - exn - (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n" - " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 1 "Sending signal/term to " pid " on " hostname) - (process-signal pid signal/term) - (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill - ;;(process-signal pid signal/kill) - ) ;; local machine, send sig term - (begin - (debug:print-info 1 "Stopping remote servers not yet supported.")))) - ;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") - ;; (let ((serverdat (list hostname port))) - ;; (case (string->symbol transport) - ;; ((http)(http-transport:client-connect hostname port)) - ;; (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet"))) - ;; (cdb:kill-server serverdat))))) ;; remote machine, try telling server to commit suicide - (begin - (if status - (if (equal? hostname (get-host-name)) - (begin - (debug:print-info 1 "Sending signal/term to " pid " on " hostname) - (process-signal pid signal/term) ;; local machine, send sig term - (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill - (process-signal pid signal/kill)) - (debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname)))))) - - +(define (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries) + ;; ensure a server is running for this run + (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)) + (delay-time 0)) + (if (and (not server-dat) + (< delay-time delay-max-tries)) + (begin + (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) + (debug:print 0 "Try starting server for run-id " run-id)) + (server:kind-run run-id) + (thread-sleep! (min delay-time 5)) + (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) (define (tasks:get-all-servers mdb) (let ((res '())) (sqlite3:for-each-row - (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport) - (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport) res))) + (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 + (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) mdb - "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport FROM servers ORDER BY start_time DESC;") + "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;") res)) - + +;; no elegance here ... +;; +(define (tasks:kill-server hostname pid) + (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname) + (setenv "TARGETHOST" hostname) + (setenv "TARGETHOST_LOGF" "server-kills.log") + (system (conc "nbfake kill " pid)) + (unsetenv "TARGETHOST_LOGF") + (unsetenv "TARGETHOST")) + +;; look up a server by run-id and send it a kill, also delete the record for that server +;; +(define (tasks:kill-server-run-id run-id #!key (tag "default")) + (let* ((tdbdat (tasks:open-db)) + (sdat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) + (if sdat + (let ((hostname (vector-ref sdat 6)) + (pid (vector-ref sdat 5)) + (server-id (vector-ref sdat 0))) + (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") + (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) + (tasks:kill-server hostname pid) + (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) + (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) + ;; (sqlite3:finalize! tdb) + )) + ;;====================================================================== ;; Tasks and Task monitors ;;====================================================================== @@ -314,19 +458,18 @@ "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;; register a task -(define (tasks:add mdb action owner target runname test item params) - (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,test,item,params,creation_time,execution_time) - VALUES (?,?,'new',?,?,?,?,?,strftime('%s','now'),0);" +(define (tasks:add mdb action owner target runname testpatt params) + (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) + VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" action owner target runname - test - item + testpatt (if params params ""))) (define (keys:key-vals-hash->target keys key-params) (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) (if (> (length keys) 1) @@ -406,11 +549,11 @@ ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc *toppath* "/monitor.db")) + (monitordbf (conc (configf:lookup *configdat* "setup" "linktree") "/.db/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue @@ -504,10 +647,91 @@ (define (tasks:set-state mdb task-id state) (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)) + +;;====================================================================== +;; Access using task key (stored in params; (hash-table->alist flags) hostname pid +;;====================================================================== + +(define (tasks:param-key->id mdb task-params) + (handle-exceptions + exn + #f + (sqlite3:first-result mdb "SELECT id FROM tasks_queue WHERE params LIKE ?;" task-params))) + +(define (tasks:set-state-given-param-key mdb param-key new-state) + (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)) + +(define (tasks:get-records-given-param-key mdb param-key state-patt action-patt test-patt) + (handle-exceptions + exn + '() + (sqlite3:first-row mdb "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE + params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" + param-key state-patt action-patt test-patt))) + + +;;====================================================================== +;; Rogue items, no place to put these yet +;;====================================================================== + +(define (tasks:find-task-queue-records mdb target run-name test-patt state-patt action-patt) + ;; (handle-exceptions + ;; exn + ;; '() + ;; (sqlite3:first-row + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (cons a b) res))) + mdb "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue + WHERE + target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" + target run-name state-patt action-patt test-patt) + res)) ;; ) + + +(define (tasks:kill-runner mdb target run-name) + (let ((records (tasks:find-task-queue-records mdb target run-name "%" "running" "run-tests")) + (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string + (if (null? records) + (debug:print 0 "No run launching processes found for " target " / " run-name) + (debug:print 0 "Found " (length records) " run(s) to kill.")) + (for-each + (lambda (record) + (let* ((param-key (list-ref record 8)) + (match-dat (string-search hostpid-rx param-key))) + (if match-dat + (let ((hostname (cadr match-dat)) + (pid (string->number (caddr match-dat)))) + (debug:print 0 "Sending SIGINT to process " pid " on host " hostname) + (if (equal? (get-host-name) hostname) + (if (process:alive? pid) + (begin + (handle-exceptions + exn + (begin + (debug:print 0 "Kill of process " pid " on host " hostname " failed.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + #t) + (process-signal pid signal/int) + (thread-sleep! 5) + (if (process:alive? pid) + (process-signal pid signal/kill))))) + ;; (call-with-environment-variables + (let ((old-targethost (getenv "TARGETHOST"))) + (setenv "TARGETHOST" hostname) + (setenv "TARGETHOST_LOGF" "server-kills.log") + (system (conc "nbfake kill " pid)) + (if old-targethost (setenv "TARGETHOST" old-targethost)) + (unsetenv "TARGETHOST") + (unsetenv "TARGETHOST_LOGF")))) + (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in monitor.db")))) + records))) + ;;====================================================================== ;; The routines to process tasks ;;====================================================================== @@ -531,15 +755,15 @@ (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) (define (tasks:rollup-runs db mdb task) (let* ((flags (make-hash-table)) (keys (db:get-keys db)) - (keyvallst (keys:target->keyval keys (tasks:task-get-target task)))) + (keyvals (keys:target-keyval keys (tasks:task-get-target task)))) ;; (hash-table-set! flags "-rerun" "NOT_STARTED") (print "Starting rollup " task) ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY (runs:rollup-run db keys - keyvallst + keyvals (tasks:task-get-name task) (tasks:task-get-owner task)) (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) ADDED tdb.scm Index: tdb.scm ================================================================== --- /dev/null +++ tdb.scm @@ -0,0 +1,372 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Database access +;;====================================================================== + +(require-extension (srfi 18) extras tcp) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit tdb)) +(declare (uses common)) +(declare (uses keys)) +(declare (uses ods)) +(declare (uses client)) +(declare (uses mt)) +(declare (uses db)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") + +;;====================================================================== +;; +;; T E S T D A T A B A S E S +;; +;;====================================================================== + +;;====================================================================== +;; T E S T S P E C I F I C D B +;;====================================================================== + +;; Create the sqlite db for the individual test(s) +(define (open-test-db work-area) + (debug:print-info 11 "open-test-db " work-area) + (if (and work-area + (directory? work-area) + (file-read-access? work-area)) + (let* ((dbpath (conc work-area "/testdat.db")) + (tdb-writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath)) + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" + ((condition-property-accessor 'exn 'message) exn)) + (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access + (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery + (set! db (sqlite3:open-database dbpath))) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (if (not dbexists) + (begin + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") + (debug:print-info 11 "Initialized test database " dbpath) + (tdb:testdb-initialize db))) + ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + (debug:print-info 11 "open-test-db END (sucessful)" work-area) + ;; now let's test that everything is correct + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " + dbpath ".\n " + ((condition-property-accessor 'exn 'message) exn)) + #f) + ;; Is there a cheaper single line operation that will check for existance of a table + ;; and raise an exception ? + (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) + db) + (let ((baddb (sqlite3:open-database ":memory:"))) + (debug:print-info 11 "open-test-db END (unsucessful)" work-area) + ;; provide an in-mem db (this is dangerous!) + (tdb:testdb-initialize baddb) + baddb))) + +;; find and open the testdat.db file for an existing test +(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) + (let* ((test-path (if work-area + work-area + (rmt:test-get-rundir-from-test-id test-id)))) + (debug:print 3 "TEST PATH: " test-path) + (open-test-db test-path))) + +;; find and open the testdat.db file for an existing test +(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) + (let* ((test-path (if work-area + work-area + (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) + (debug:print 3 "TEST PATH: " test-path) + (open-test-db test-path))) + +;; find and open the testdat.db file for an existing test +(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) + (let* ((test-path (if work-area + work-area + (db:test-get-rundir-from-test-id dbstruct run-id test-id))) + (tdb (open-test-db test-path))) + (apply proc tdb params))) + +(define (tdb:testdb-initialize db) + (debug:print 11 "db:testdb-initialize START") + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (sqlcmd) + (sqlite3:execute db sqlcmd)) + (list "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);" + "CREATE TABLE IF NOT EXISTS test_data ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + category TEXT DEFAULT '', + variable TEXT, + value REAL, + expected REAL, + tol REAL, + units TEXT, + comment TEXT DEFAULT '', + status TEXT DEFAULT 'n/a', + type TEXT DEFAULT '', + CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" + "CREATE TABLE IF NOT EXISTS test_steps ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + event_time TIMESTAMP, + comment TEXT DEFAULT '', + logfile TEXT DEFAULT '', + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" + ;; test_meta can be used for handing commands to the test + ;; e.g. KILLREQ + ;; the ackstate is set to 1 once the command has been completed + "CREATE TABLE IF NOT EXISTS test_meta ( + id INTEGER PRIMARY KEY, + var TEXT, + val TEXT, + ackstate INTEGER DEFAULT 0, + CONSTRAINT metadat_constraint UNIQUE (var));")))) + (debug:print 11 "db:testdb-initialize END")) + +(define (tdb:read-test-data tdb test-id categorypatt) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + tdb + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) + (sqlite3:finalize! tdb) + (reverse res))) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== + +;; ;; get a list of test_data records matching categorypatt +;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f)) +;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) +;; (if (sqlite3:database? tdb) +;; (let ((res '())) +;; (sqlite3:for-each-row +;; (lambda (id test_id category variable value expected tol units comment status type) +;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) +;; tdb +;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) +;; (sqlite3:finalize! tdb) +;; (reverse res)) +;; '()))) + +;; NOTE: Run this local with #f for db !!! +(define (tdb:load-test-data run-id test-id) + (let loop ((lin (read-line))) + (if (not (eof-object? lin)) + (begin + (debug:print 4 lin) + (rmt:csv->test-data run-id test-id lin) + (loop (read-line))))) + ;; roll up the current results. + ;; FIXME: Add the status too + (rmt:test-data-rollup run-id test-id #f)) + +(define (tdb:get-prev-tol-for-test tdb test-id category variable) + ;; Finish me? + (values #f #f #f)) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +(define (tdb:step-get-time-as-string vec) + (seconds->time-string (tdb:step-get-event_time vec))) + +;; get a pretty table to summarize steps +;; +(define (tdb:get-steps-table steps);; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (tdb:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +;; Move this to steps.scm +;; +;; get a pretty table to summarize steps +;; +(define (tdb:get-steps-table-list steps) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (tdb:step-get-stepname step) + ;; stepname start end status + (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +;; +;; Move to steps.scm +;; +(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt) (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;; -(define (tests:match patterns testname itempath) +(define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) - (let ((patts (string-split patterns ","))) + (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match #f (let loop ((patt (car patts)) (tal (cdr patts))) ;; (print "loop: patt: " patt ", tal " tal) @@ -103,169 +128,94 @@ (if (null? tal) (string-intersperse (append (reverse res)(list qry)) " OR ") (loop (car tal)(cdr tal)(cons qry res))))))) #f)) -;; get the previous record for when this test was run where all keys match but runname -;; returns #f if no such test found, returns a single test record if found -(define (test:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (cdb:remote-run db:get-keys #f)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) - (keyvals #f)) - ;; first look up the key values from the run selected by run-id - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - #f - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; for each run starting with the most recent look to see if there is a matching test - ;; if found then return that matching test record - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) #f - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (cdb:remote-run db:get-tests-for-run #f hed (conc test-name "/" item-path)'() '()))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) - (if (and (null? results) - (not (null? tal))) - (loop (car tal)(cdr tal)) - (if (null? results) #f - (car results)))))))))) - -;; get the previous records for when these tests were run where all keys match but runname -;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests -;; can use wildcards. Also can likely be factored in with get test paths? -(define (test:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (cdb:remote-run db:get-keys #f)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) - (keyvals #f) - (tests-hash (make-hash-table))) - ;; first look up the key values from the run selected by run-id - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - '() - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; collect all matching tests for the runs then - ;; extract the most recent test and return that. - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals - ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) '() ;; no previous runs? return null - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (cdb:remote-run db:get-tests-for-run #f hed (conc test-name "/" item-path) '() '()))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name - ", item-path " item-path " results: " (intersperse results "\n")) - ;; Keep only the youngest of any test/item combination - (for-each - (lambda (testdat) - (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) - (stored-test (hash-table-ref/default tests-hash full-testname #f))) - (if (or (not stored-test) - (and stored-test - (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) - ;; this test is younger, store it in the hash - (hash-table-set! tests-hash full-testname testdat)))) - results) - (if (null? tal) - (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests - (loop (car tal)(cdr tal)))))))))) - ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) - (let* ((testconfig (tests:get-testconfig (db:test-get-testname testdat) #f)) - (test-rundir (db:test-get-rundir testdat)) - (prev-rundir (db:test-get-rundir prev-testdat)) + (let* ((test-registry (make-hash-table)) + (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) + (test-rundir ;; (sdb:qry 'passstr + (db:test-get-rundir testdat)) ;; ) + (prev-rundir ;; (sdb:qry 'passstr + (db:test-get-rundir prev-testdat)) ;; ) (waivers (configf:section-vars testconfig "waivers")) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) - (push-directory test-rundir) - (let ((result (if (null? waivers) - #f - (let loop ((hed (car waivers)) - (tal (cdr waivers))) - (debug:print 0 "INFO: Applying waiver rule \"" hed "\"") - (let* ((waiver (configf:lookup testconfig "waivers" hed)) - (wparts (if waiver (string-match waiver-rx waiver) #f)) - (waiver-rule (if wparts (cadr wparts) #f)) - (waiver-glob (if wparts (caddr wparts) #f)) - (logpro-file (if waiver - (let ((fname (conc hed ".logpro"))) - (if (file-exists? fname) - fname - (begin - (debug:print 0 "INFO: No logpro file " fname " falling back to diff") - #f))) - #f)) - ;; if rule by name of waiver-rule is found in testconfig - use it - ;; else if waivername.logpro exists use logpro-rule - ;; else default to diff-rule - (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule))) - (if rule - rule - (if logpro-file - logpro-rule - (begin - (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule") - diff-rule))))) - ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) - (processed-cmd (string-substitute - "%file1%" (conc test-rundir "/" waiver-glob) - (string-substitute - "%file2%" (conc prev-rundir "/" waiver-glob) - (string-substitute - "%waivername%" hed rule-string #t) #t) #t)) - (res #f)) - (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"") - (if (eq? (system processed-cmd) 0) - (if (null? tal) - #t - (loop (car tal)(cdr tal))) - #f)))))) - (pop-directory) - result))) - + (if (not (file-exists? test-rundir)) + (begin + (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver") + #f) + (begin + (push-directory test-rundir) + (let ((result (if (null? waivers) + #f + (let loop ((hed (car waivers)) + (tal (cdr waivers))) + (debug:print 0 "INFO: Applying waiver rule \"" hed "\"") + (let* ((waiver (configf:lookup testconfig "waivers" hed)) + (wparts (if waiver (string-match waiver-rx waiver) #f)) + (waiver-rule (if wparts (cadr wparts) #f)) + (waiver-glob (if wparts (caddr wparts) #f)) + (logpro-file (if waiver + (let ((fname (conc hed ".logpro"))) + (if (file-exists? fname) + fname + (begin + (debug:print 0 "INFO: No logpro file " fname " falling back to diff") + #f))) + #f)) + ;; if rule by name of waiver-rule is found in testconfig - use it + ;; else if waivername.logpro exists use logpro-rule + ;; else default to diff-rule + (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule))) + (if rule + rule + (if logpro-file + logpro-rule + (begin + (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule") + diff-rule))))) + ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) + (processed-cmd (string-substitute + "%file1%" (conc test-rundir "/" waiver-glob) + (string-substitute + "%file2%" (conc prev-rundir "/" waiver-glob) + (string-substitute + "%waivername%" hed rule-string #t) #t) #t)) + (res #f)) + (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"") + (if (eq? (system processed-cmd) 0) + (if (null? tal) + #t + (loop (car tal)(cdr tal))) + #f)))))) + (pop-directory) + result))))) + +(define (tests:test-force-state-status! run-id test-id state status) + (rmt:test-set-status-state run-id test-id status state #f) + (mt:process-triggers run-id test-id state status)) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! test-id state status comment dat) - (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) - (let* ((db #f) - (real-status status) +(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) + (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (cdb:get-test-info-by-id *runremote* test-id)) - (run-id (db:test-get-run_id testdat)) - (test-name (db:test-get-testname testdat)) + (testdat (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? ;; 2. Add test for testconfig waiver propagation control here ;; (prev-test (if (equal? status "FAIL") - (open-run-close test:get-previous-test-run-record db run-id test-name item-path) + (rmt:get-previous-test-run-record run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) @@ -285,16 +235,18 @@ (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))) + (begin + (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) + (mt:process-triggers run-id test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup #f test-id status)) + (rmt:test-data-rollup run-id test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -324,134 +276,171 @@ expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) - (cdb:remote-run db:csv->test-data #f test-id + ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. + (rmt:csv->test-data run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path status)) + (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (cdb:remote-run db:test-set-comment #f test-id cmt))) - )) - - -(define (tests:test-set-toplog! db run-id test-name logf) - (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name)) - -(define (tests:summarize-items db run-id test-name force) + (rmt:general-call 'set-test-comment run-id cmt test-id))))) + +(define (tests:test-set-toplog! run-id test-name logf) + (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) + +(define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) - (logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name)) + (logf-info (rmt:test-get-logfile-info run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test - (if (directory? path) + (if (and (string? path) + (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (print "No such path: " path)) + (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin - (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock - (print "Obtained lock for " outputfilename) - (print "Failed to obtain lock for " outputfilename)) - (let ((oup (open-output-file outputfilename)) - (counts (make-hash-table)) - (statecounts (make-hash-table)) - (outtxt "") - (tot 0) - (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name))) - (with-output-to-port - oup - (lambda () - (set! outtxt (conc outtxt "Summary: " test-name - "

Summary for " test-name "

")) - (for-each - (lambda (testrecord) - (let ((id (vector-ref testrecord 0)) - (itempath (vector-ref testrecord 1)) - (state (vector-ref testrecord 2)) - (status (vector-ref testrecord 3)) - (run_duration (vector-ref testrecord 4)) - (logf (vector-ref testrecord 5)) - (comment (vector-ref testrecord 6))) - (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) - (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) - (set! outtxt (conc outtxt "" - " " itempath "" - "" state "" - "" status "" - "" (if (equal? comment "") - " " - comment) "" - "")))) - testdat) - (print "
") - ;; Print out stats for status - (set! tot 0) - (print "") - (for-each (lambda (state) - (set! tot (+ tot (hash-table-ref statecounts state))) - (print "")) - (hash-table-keys statecounts)) - (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") - (print "		") - ;; Print out stats for state - (set! tot 0) - (print "") - (for-each (lambda (status) - (set! tot (+ tot (hash-table-ref counts status))) - (print "")) - (hash-table-keys counts)) - (print "

Status stats

" status - "" (hash-table-ref counts status) "
Total" tot "
") - (print "
") - - (print "" - "" - outtxt "
ItemStateStatusComment
") - (release-dot-lock outputfilename))) - (close-output-port oup) - (change-directory orig-dir) - ;; NB// tests:test-set-toplog! is remote internal... - (tests:test-set-toplog! db run-id test-name outputfilename) - ))))) - -(define (get-all-legal-tests) - (let* ((tests (glob (conc *toppath* "/tests/*"))) - (res '())) - (debug:print-info 4 "Looking at tests " (string-intersperse tests ",")) - (for-each (lambda (testpath) - (if (file-exists? (conc testpath "/testconfig")) - (set! res (cons (last (string-split testpath "/")) res)))) - tests) - res)) - -(define (tests:get-testconfig test-name system-allowed) - (let* ((test-path (conc *toppath* "/tests/" test-name)) + (if (not (lock-queue:wait-turn outputfilename test-id)) + (print "Not updating " outputfilename " as another test item has signed up for the job") + (begin + (print "Obtained lock for " outputfilename) + (let ((oup (open-output-file outputfilename)) + (counts (make-hash-table)) + (statecounts (make-hash-table)) + (outtxt "") + (tot 0) + (testdat (rmt:test-get-records-for-index-file run-id test-name))) + (with-output-to-port + oup + (lambda () + (set! outtxt (conc outtxt "Summary: " test-name + "

Summary for " test-name "

")) + (for-each + (lambda (testrecord) + (let ((id (vector-ref testrecord 0)) + (itempath (vector-ref testrecord 1)) + (state (vector-ref testrecord 2)) + (status (vector-ref testrecord 3)) + (run_duration (vector-ref testrecord 4)) + (logf (vector-ref testrecord 5)) + (comment (vector-ref testrecord 6))) + (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) + (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) + (set! outtxt (conc outtxt "" + " " itempath "" + "" state "" + "" status "" + "" (if (equal? comment "") + " " + comment) "" + "")))) + (if (list? testdat) + testdat + (begin + (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) + '()))) + + (print "
") + ;; Print out stats for status + (set! tot 0) + (print "") + (for-each (lambda (state) + (set! tot (+ tot (hash-table-ref statecounts state))) + (print "")) + (hash-table-keys statecounts)) + (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") + (print "		") + ;; Print out stats for state + (set! tot 0) + (print "") + (for-each (lambda (status) + (set! tot (+ tot (hash-table-ref counts status))) + (print "")) + (hash-table-keys counts)) + (print "

Status stats

" status + "" (hash-table-ref counts status) "
Total" tot "
") + (print "
") + + (print "" + "" + outtxt "
ItemStateStatusComment
") + ;; (release-dot-lock outputfilename) + )) + (close-output-port oup) + (lock-queue:release-lock outputfilename test-id) + (change-directory orig-dir) + ;; NB// tests:test-set-toplog! is remote internal... + (tests:test-set-toplog! run-id test-name outputfilename) + ))))))) + +;; MUST BE CALLED local! +;; +(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) + ;; BUG: Move the values derived from args to parameters and push to megatest.scm + (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) + (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) + (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) + (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res + testpatt + statepatt + statuspatt + runname))) + (if fnamepatt + (apply append + (map (lambda (p) + (if (directory-exists? p) + (glob (conc p "/" fnamepatt)) + '())) + paths-from-db)) + paths-from-db))) + + +;;====================================================================== +;; Gather data from test/task specifications +;;====================================================================== + +;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) +;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) +;; (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) +;; (delete-duplicates +;; (filter (lambda (testname) +;; (tests:match test-patts testname #f)) +;; (map (lambda (testp) +;; (last (string-split testp "/"))) +;; tests))))) + +(define (tests:get-testconfig test-name test-registry system-allowed) + (let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) - (if testexists - (read-config test-configf #f system-allowed environ-patt: (if system-allowed - "pre-launch-env-vars" - #f)) - #f))) + (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + (tcfg (if testexists + (read-config test-configf #f system-allowed environ-patt: (if system-allowed + "pre-launch-env-vars" + #f)) + #f))) + (hash-table-set! *testconfigs* test-name tcfg) + tcfg)) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (let ((mungepriority (lambda (priority) @@ -489,11 +478,11 @@ #f ;; cannot have a which is waiting on b happening before b (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go - #f)))))))) + (string-compare3 a b))))))))) ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) @@ -503,48 +492,138 @@ (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (tdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (rmt:get-test-id run-id test-name item-path)) + (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status - (if (or (member (db:test-get-status tdat) - '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) + (if (or (and (member (db:test-get-status tdat) + '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) + (equal? (db:test-get-state tdat) "COMPLETED")) (member (db:test-get-state tdat) - '("INCOMPLETE" "KILLED"))) + '("INCOMPLETE" "KILLED"))) (set! keep-test #f)) ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let* ((parent-test-id (cdb:remote-run db:get-test-id #f run-id waiton "")) - (wtdat (cdb:get-test-info-by-id *runremote* test-id))) - (if (or (member (db:test-get-status wtdat) - '("FAIL" "KILLED")) - (member (db:test-get-state wtdat) - '("INCOMPETE"))) + (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) + (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") + (member (db:test-get-status wtdat) '("FAIL"))) + (member (db:test-get-status wtdat) '("KILLED")) + (member (db:test-get-state wtdat) '("INCOMPETE"))) + ;; (if (or (member (db:test-get-status wtdat) + ;; '("FAIL" "KILLED")) + ;; (member (db:test-get-state wtdat) + ;; '("INCOMPETE"))) (set! keep-test #f)))) ;; no point in running this one again waitons)))) (if keep-test (set! runnables (cons testkeyname runnables))))) testkeynames) runnables)) + +;;====================================================================== +;; refactoring this block into tests:get-full-data from line 263 of runs.scm +;;====================================================================== +;; hed is the test name +;; test-records is a hash of test-name => test record +(define (tests:get-full-data test-names test-records required-tests all-tests-registry) + (if (not (null? test-names)) + (let loop ((hed (car test-names)) + (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (debug:print-info 4 "hed=" hed " at top of loop") + (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) + (waitons (let ((instr (if config + (config-lookup config "requirements" "waiton") + (begin ;; No config means this is a non-existant test + (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + "")))) + (debug:print-info 8 "waitons string is " instr) + (string-split (cond + ((procedure? instr) + (let ((res (instr))) + (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + "")))))) + (if (not config) ;; this is a non-existant test called in a waiton. + (if (null? tal) + test-records + (loop (car tal)(cdr tal))) + (begin + (debug:print-info 8 "waitons: " waitons) + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member hed waitons) + (begin + (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) + + ;; (items (items:get-items-from-config config))) + (if (not (hash-table-ref/default test-records hed #f)) + (hash-table-set! test-records + hed (vector hed ;; 0 + config ;; 1 + waitons ;; 2 + (config-lookup config "requirements" "priority") ;; priority 3 + (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 + (itemstable (hash-table-ref/default config "itemstable" #f))) + ;; if either items or items table is a proc return it so test running + ;; process can know to call items:get-items-from-config + ;; if either is a list and none is a proc go ahead and call get-items + ;; otherwise return #f - this is not an iterated test + (cond + ((procedure? items) + (debug:print-info 4 "items is a procedure, will calc later") + items) ;; calc later + ((procedure? itemstable) + (debug:print-info 4 "itemstable is a procedure, will calc later") + itemstable) ;; calc later + ((filter (lambda (x) + (let ((val (car x))) + (if (procedure? val) val #f))) + (append (if (list? items) items '()) + (if (list? itemstable) itemstable '()))) + 'have-procedure) + ((or (list? items)(list? itemstable)) ;; calc now + (debug:print-info 4 "items and itemstable are lists, calc now\n" + " items: " items " itemstable: " itemstable) + (items:get-items-from-config config)) + (else #f))) ;; not iterated + #f ;; itemsdat 5 + #f ;; spare - used for item-path + ))) + (for-each + (lambda (waiton) + (if (and waiton (not (member waiton test-names))) + (begin + (set! required-tests (cons waiton required-tests)) + (set! test-names (cons waiton test-names))))) ;; was an append, now a cons + waitons) + (let ((remtests (delete-duplicates (append waitons tal)))) + (if (not (null? remtests)) + (loop (car remtests)(cdr remtests)) + test-records)))))))) ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* (;; (item-path (item-list->path itemdat)) - (testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) - (equal? (test:get-state testdat) "KILLREQ"))) +(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) + (and testdat + (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb (let ((res 0)) (sqlite3:for-each-row @@ -553,33 +632,51 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (db:update-central-meta-info db test-id cpuload diskfree minutes num-records uname hostname) - (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;" - cpuload - diskfree - test-id) - (if minutes (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" minutes test-id)) - (if (eq? num-records 0) - (sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE id=?;" - uname hostname test-id))) - -(define (test-set-meta-info db test-id run-id testname itemdat minutes) - ;; DOES cdb:remote-run under the hood! - (let* ((tdb (db:open-test-db-by-test-id db test-id)) - (num-records (test:tdb-get-rundat-count tdb)) - (cpuload (get-cpu-load)) - (diskfree (get-df (current-directory)))) - (if (eq? (modulo num-records 10) 0) ;; every ten records update central - (let ((uname (get-uname "-srvpio")) - (hostname (get-host-name))) - (cdb:remote-run db:update-central-meta-info db test-id cpuload diskfree minutes num-records uname hostname))) - (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" - cpuload diskfree minutes))) - +(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) + (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) + (if minutes + (rmt:general-call 'update-run-duration run-id minutes test-id)) + (if (and uname hostname) + (rmt:general-call 'update-uname-host run-id uname hostname test-id))) + +;; This one is for running with no db access (i.e. via rmt: internally) +(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) +;; (define (tests:set-full-meta-info test-id run-id minutes work-area) +;; (let ((remtries 10)) + (let* ((cpuload (get-cpu-load)) + (diskfree (get-df (current-directory))) + (uname (get-uname "-srvpio")) + (hostname (get-host-name))) + (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) + +;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) +(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) + (let* ((cpuload (get-cpu-load)) + (diskfree (get-df (current-directory))) + (remtries 10)) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (print-call-chain (current-error-port)) + (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times") + (set! remtries (- remtries 1)) + (thread-sleep! 10) + (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain (current-error-port)))) + (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) + ))) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,98 +1,195 @@ +# # run some tests -BINPATH=$(PWD)/../bin -MEGATEST=$(BINPATH)/megatest -PATH := $(BINPATH):$(PATH) -RUNNAME := $(shell date +w%V.%u.%H.%M) -IPADDR := "-" -# Set SERVER to "-server -" -SERVER = -DEBUG = 1 -LOGGING = +BINPATH = $(shell readlink -m $(PWD)/../bin) +MEGATEST = $(BINPATH)/megatest +DASHBOARD = $(BINPATH)/dashboard +PATH := $(BINPATH):$(PATH) +RUNNAME := $(shell date +w%V.%u.%H.%M) +IPADDR := "-" +RUNID := 1 +SERVER = +DEBUG = 1 +LOGGING = +ROWS = 20 OS = $(shell grep ID /etc/*-release|cut -d= -f2) FS = $(shell df -T .|tail -1|awk '{print $$2}') VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5) # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : test1 test2 test3 test4 test5 +all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9 + +unit : + ./rununittest.sh basicserver $(DEBUG) server : - (cd ..;make;make install) && \ - (cd fullrun;../../bin/megatest -server - -debug 22) + cd ..;make -j;make install + cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) + +stopserver : + cd ..;make -j && make install + cd fullrun;$(MEGATEST) -stop-server 0 + +repl : + cd ..;make -j && make install + cd fullrun;$(MEGATEST) -repl test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep - rm -f simplerun/megatest.db - rm -rf simplelinks/ simpleruns/ - mkdir -p simplelinks simpleruns - cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm - cd simplerun;echo '(load "../tests.scm")' | $(MEGATEST) -repl -debug $(DEBUG) test2 : fullprep - cd fullrun;$(MEGATEST) -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) - cd fullrun;megatest -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) - cd fullrun;megatest -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) - cd fullrun;megatest -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) + cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) + cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) -test3 : fullprep - cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 +test3 : fullprep test3a test3b + +test3a : + @echo Run runfirst and any waitons. + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + +test3b : + @echo Run all_toplevel and all waitons + cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c + +test4 : cleanprep + @echo "WARNING: No longer running fullprep, test converage may be lessened" + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) -test4 : fullprep - cd fullrun;$(MEGATEST) -debug $(DEBUG) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) +test4a : cleanprep + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) # NOTE: Only one instance can be a server -test5 : fullprep - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & -# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & -# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & +test5 : cleanprep + @echo "WARNING: No longer running fullprep, test converage may be lessened" + cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & + cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & + cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & + cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & +# cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & +# cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & + +# MUST ADD THIS BACK IN ASAP!!!! + # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep - cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v - cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 +test7: + @echo Only a/c testname c should remain. If there is a run a/b/c then there is a cache issue. + cd simplerun;$(DASHBOARD) & + (cd simplerun; \ + $(MEGATEST) -server - -daemonize; \ + $(MEGATEST) -remove-runs -target %/% :runname % -testpatt %; \ + $(MEGATEST) -preclean -runtests % -target a/b :runname c; sleep 5; \ + $(MEGATEST) -remove-runs -target a/c :runname c; \ + $(MEGATEST) -preclean -runtests % -target a/c :runname c; \ + $(MEGATEST) -remove-runs -target a/b :runname c -testpatt % ; \ + $(MEGATEST) -preclean -runtests % -target a/d :runname c;$(MEGATEST) -list-runs %|egrep ^Run:) > test7.log 2> test7.log + logpro test7.logpro test7.html < test7.log + @echo + @echo Run \"firefox test7.html\" to see the results. + +# This one failed with v1.55 +test8a : + cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target ubuntu/nfs/none :runname $(RUNNAME)_waiton_single + +test8 : test8a + cd fullrun;$(MEGATEST) -preclean -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest + cd fullrun;$(MEGATEST) -preclean -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem + cd fullrun;$(MEGATEST) -preclean -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton + +# Some simple checks for bootstrapping and run loop logic + +test9 : minsetup test9a test9b test9c test9d test9e + +test9a : + @echo Run super-simple mintest e, no waitons. + cd mintest;$(DASHBOARD)& + cd mintest;$(MEGATEST) -preclean -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9b : + @echo Run simple mintest d with one waiton c + cd mintest;$(MEGATEST) -preclean -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9c : + @echo Run mintest a with full waiton chain a -> b -> c -> d -> e + cd mintest;$(MEGATEST) -preclean -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9d : + @echo Run an itemized test with no items + cd mintest;$(MEGATEST) -preclean -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9e : + @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 + cd mintest;$(MEGATEST) -preclean -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test10 : + @echo Run a bunch of different targets simultaneously + (cd fullrun;$(MEGATEST) -server - ;sleep 2)& + for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ + (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done + for sys in ubuntu suse redhat debian;do \ + for fs in afs nfs zfs; do \ + for dpath in none tmp; do \ + (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ + done;done;done + +test11 : + cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) + +minsetup : + cd ..;make -j && make install + mkdir -p mintest/runs mintest/links + cd mintest;$(MEGATEST) -stop-server 0 + cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & + sleep 3 + cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config - mkdir -p /tmp/mt_runs /tmp/mt_links - cd ..;make;make install + mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links + cd ..;make -j;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep - cd fullrun && $(BINPATH)/dashboard -rows 25 & + cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & + +newdashboard : cleanprep + cd fullrun && $(BINPATH)/newdashboard & remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep kill : killall -v mtest main.sh dboard || true - rm -f */megatest.db */logging.db */monitor.db || true + rm -rf /tmp/.$(USER)-portlogger.db *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* fullrun/logs/*.log fullrun/*.log || true killall -v mtest dboard || true hardkill : kill - sleep 5;killall -v mtest main.sh dboard -9 + sleep 2;killall -v mtest main.sh dboard -9 listservers : - cd fullrun;$(MEGATEST) -listservers + cd fullrun;$(MEGATEST) -list-servers runforever : while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done Index: tests/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -2,11 +2,32 @@ SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines -max_concurrent_jobs 500 +# max_concurrent_jobs 150 +max_concurrent_jobs 1000 # This is your link path, you can move it but it is generally better to keep it stable -linktree #{shell readlink -f #{getenv PWD}/../simplelinks} +linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks} [include testqa/configs/megatest.abc.config] + +# timeout 0.025 + +[jobtools] +maxload 4 +launcher nbfake + +[server] +# timeout 0.01 +# homehost xena +# homehost 143.182.225.38 + +# force server +server-query-threshold 0 + + +[jobtools] +# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk +# launcher nbfake +# maxload 4 ADDED tests/fdktestqa/testqa/Makefile Index: tests/fdktestqa/testqa/Makefile ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/Makefile @@ -0,0 +1,38 @@ +BINDIR = $(PWD)/../../../bin +PATH := $(BINDIR):$(PATH) +MEGATEST = $(BINDIR)/megatest +DASHBOARD = $(BINDIR)/dashboard +NEWDASHBOARD = $(BINDIR)/newdashboard +RUNNAME = a + + +all : + $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% + $(MEGATEST) -runtests % -target a/b :runname c + +bigbig : + for tn in a b c d;do \ + ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ + done + +bigrun : + $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) + +bigrun2 : + $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) + +bigrun3 : + $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) + +dashboard : + $(DASHBOARD) -rows 20 & + +newdashboard : + $(NEWDASHBOARD) & + +compile : + (cd ../../..;make -j && make install) + +clean : + rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db + ADDED tests/fdktestqa/testqa/README Index: tests/fdktestqa/testqa/README ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/README @@ -0,0 +1,1 @@ +set NUMTESTS to set the number of tests that will be run. A small number (say 20) illustrates itemwait well. Index: tests/fdktestqa/testqa/configs/megatest.abc.config ================================================================== --- tests/fdktestqa/testqa/configs/megatest.abc.config +++ tests/fdktestqa/testqa/configs/megatest.abc.config @@ -2,9 +2,8 @@ [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] -useshell yes -launcher nbfake +# useshell yes [include megatest.def.config] Index: tests/fdktestqa/testqa/configs/megatest.def.config ================================================================== --- tests/fdktestqa/testqa/configs/megatest.def.config +++ tests/fdktestqa/testqa/configs/megatest.def.config @@ -2,7 +2,7 @@ [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] -disk0 #{scheme (nice-path "#{getenv PWD}/../simpleruns")} +disk0 #{scheme (nice-path "#{getenv MT_RUN_AREA_HOME}/../simpleruns")} Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,5 +1,9 @@ [setup] -testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. +testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log +# launchwait no + +[jobtools] +launcher nbfake [include ../fdk.config] ADDED tests/fdktestqa/testqa/runsuite.sh Index: tests/fdktestqa/testqa/runsuite.sh ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/runsuite.sh @@ -0,0 +1,18 @@ +#!/bin/bash + +(cd ../../..;make && make install) || exit 1 +export PATH=$PWD/../../../bin:$PATH + +for i in a b c d e f;do + # g h i j k l m n o p q r s t u v w x y z;do + megatest -runtests % -target a/b :runname $i & +done + +echo "" > num-running.log +while true; do + foo=`megatest -list-runs % | grep RUNNING | wc -l` + echo "Num running at `date` $foo" + echo "$foo at `date`" >> num-running.log + # to make the test go at a reasonable clip only gather this info ever minute + sleep 1m +done Index: tests/fdktestqa/testqa/tests/bigrun/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun/step1.sh @@ -1,3 +1,13 @@ -#!/bin/sh -sleep 10 -exit 0 +#!/bin/bash +if [ $NUMBER -lt 10 ];then + sleep 20 + sleep `echo 4 * $NUMBER | bc` +else + sleep 130 +fi + +if [[ $RANDOM -lt 10000 ]];then + exit 1 +else + exit 0 +fi Index: tests/fdktestqa/testqa/tests/bigrun/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/testconfig +++ tests/fdktestqa/testqa/tests/bigrun/testconfig @@ -1,17 +1,20 @@ # Add additional steps here. Format is "stepname script" +[vars] +step1var step1.sh + [ezsteps] -step1 step1.sh +step1 #{get vars step1var} # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 120)(loop (+ a 1)(cons a res)) res)) >)) " ")} +NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500))(loop (+ a 1)(cons a res)) res)) <)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt Index: tests/fdktestqa/testqa/tests/bigrun2/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun2/step1.sh @@ -1,7 +1,9 @@ #!/bin/sh -prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` -if [ -e $prev_test/testconfig ]; then - exit 0 -else - exit 1 -fi +# prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` +# if [ -e $prev_test/testconfig ]; then +# exit 0 +# else +# exit 1 +# fi + +exit 0 Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -4,16 +4,20 @@ # Test requirements are specified here [requirements] waiton bigrun priority 0 -mode itemmatch - +mode itemwait +itemmap .*/ # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 120)(loop (+ a 1)(cons a res)) res)) >)) " ")} +NUMBER #{scheme (string-intersperse (map (lambda (x)(conc "blah/" x)) \ + (map number->string (sort (let loop ((a 0)(res '())) \ + (if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500)) \ + (loop (+ a 1)(cons a res)) res)) <))) " ")} + # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt ADDED tests/fdktestqa/testqa/tests/bigrun3/step1.sh Index: tests/fdktestqa/testqa/tests/bigrun3/step1.sh ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/tests/bigrun3/step1.sh @@ -0,0 +1,9 @@ +#!/bin/sh +# prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` +# if [ -e $prev_test/testconfig ]; then +# exit 0 +# else +# exit 1 +# fi + +exit 0 ADDED tests/fdktestqa/testqa/tests/bigrun3/testconfig Index: tests/fdktestqa/testqa/tests/bigrun3/testconfig ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/tests/bigrun3/testconfig @@ -0,0 +1,25 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +step1 step1.sh + +# Test requirements are specified here +[requirements] +waiton bigrun2 +priority 0 +mode itemwait +itemmap .*/ + +# Iteration for your tests are controlled by the items section +[items] +NUMBER #{scheme (string-intersperse (map (lambda (x)(conc "blah/" x)) \ + (map number->string (sort (let loop ((a 0)(res '())) \ + (if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500)) \ + (loop (+ a 1)(cons a res)) res)) <))) " ")} + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description An example test +tags tagone,tagtwo +reviewed never ADDED tests/fullrun/afs.config Index: tests/fullrun/afs.config ================================================================== --- /dev/null +++ tests/fullrun/afs.config @@ -0,0 +1,1 @@ +TESTSTORUN priority_6 sqlitespeed/ag Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,18 +1,29 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 200 +max_concurrent_jobs 50 linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes -launcher nbfake +# launcher exec nbfake +# launcher nbfake +# launcher loadrunner +# launcher echo +# launcher nbfind # launcher nodanggood +# launcher loadrunner +launcher nbfake +# maxload *per cpu* +maxload 1.5 +# default waitdelay is 60 seconds +waitdelay 15 + ## use "xterm -e csi -- " as a launcher to examine the launch environment. ## exit with (exit) ## get a shell with (system "bash") # launcher xterm -e csi -- Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -8,39 +8,104 @@ [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] +[dashboard] +pre-command xterm -geometry 180x20 -e " +post-command |& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" & +testsort -event_time + +[misc] +home #{shell readlink -f $MT_RUN_AREA_HOME} +parent #{shell readlink -f $MT_RUN_AREA_HOME/..} + +[tests-paths] +1 #{get misc parent}/simplerun/tests + [setup] +# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding +# this may save a few milliseconds on launching tests +# launchwait no +waivercommentpatt ^WW\d+ [a-z].* +incomplete-timeout 1 + +# yes, anything else is no +run-wait yes + + +# Use http instead of direct filesystem access +# transport http +# transport fs + +# If set to "default" the old code is used. Otherwise defaults to 200 or uses +# numeric value given. +# +runqueue 20 + +# Default runtimelim 1d 1h 1m 10s +# +runtimelim 20m + +# Deadtime - when to consider tests dead (i.e. haven't heard from them in too long) +# Number in seconds, set to 20 seconds here to trigger a little trouble. Default is +# 1800 +# +deadtime 600 # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # -testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 -synchronous OFF +synchronous 0 # Throttle roughly scales the db access milliseconds to seconds delay throttle 0.2 # Max retries allows megatest to re-check that a tests status has changed # as tests can have transient FAIL status occasionally maxretries 20 +# Setup continued. +[setup] + +# override the logview command +# +logviewer (%MTCMD%) 2> /dev/null > /dev/null + +# override the html viewer launch command +# +# htmlviewercmd firefox -new-window +htmlviewercmd konqueror + +# -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run +# (nb// this is in addition to NOT_STARTED which is automatically re-run) +# +allow-auto-rerun INCOMPLETE ZERO_ITEMS +# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD + [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] + +# This variable is honored by the loadrunner script. The value is in percent +MAX_ALLOWED_LOAD 200 + +# MT_XTERM_CMD overrides the terminal command +# MT_XTERM_CMD xterm -bg lightgreen -fg black + SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs -TESTVAR [system realpath .] +TESTVAR [system echo $PWD] DEADVAR [system ls] VARWITHDOLLAR $HOME/.zshrc WACKYVAR #{system ls > /dev/null} WACKYVAR2 #{get validvalues state} WACKYVAR3 #{getenv USER} @@ -50,27 +115,56 @@ PREDICTABLE the_ans MRAH MT_RUN_AREA_HOME=#{getenv MT_RUN_AREA_HOME} # The empty var should have a definition with null string EMPTY_VAR +WRAPPEDVAR This var should have the work blah thrice: \ +blah \ +blah + +MAX_ALLOWED_LOAD 200 # XTERM [system xterm] # RUNDEAD [system exit 56] [server] +synchronous 0 # If the server can't be started on this port it will try the next port until # it succeeds port 8080 # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours -timeout 0.05 +# timeout 0.025 +timeout 0.1 + +# Server is required - slower but more resistant to Sqlite issues. +# required yes + +# Start server when average query takes longer than this +server-query-threshold 100 +# 55500 + +# daemonize yes +# hostname #{scheme (get-host-name)} ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] disk0 /foobarbazz +disk1 not-a-disk [include config/mt_include_2.config] [include #{getenv USER}_testing.config] + +[jobgroups] + +# NOTE: job groups will falsely count the toplevel test as a job. If possible add N +# to your jobgroups where N is the number of parallel runs you are likely to see +# +sqlite3 6 +blockz 10 +# to your jobgroups where N is the number of parallel runs you are likely to see +# + ADDED tests/fullrun/nfs.config Index: tests/fullrun/nfs.config ================================================================== --- /dev/null +++ tests/fullrun/nfs.config @@ -0,0 +1,1 @@ +TESTSTORUN priority_4 test_mt_vars ADDED tests/fullrun/run-each-proc.sh Index: tests/fullrun/run-each-proc.sh ================================================================== --- /dev/null +++ tests/fullrun/run-each-proc.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +for x in `cat all-db-procs.txt`;do + cat > ~/.megatestrc <' '-_g'` + megatest -runtests sqlitespeed,test2,ez% -target ubuntu/nfs/none :runname $fname > $fname.log +done + + Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,13 +1,30 @@ +[default] +SOMEVAR This should show up in SOMEVAR3 + +# target based getting of config file, look at afs.config and nfs.config +[include #{getenv fsname}.config] + [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] # #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/config/$USER.config} [include ./config/#{getenv USER}.config] + WACKYVAR0 #{get ubuntu/nfs/none CURRENT} WACKYVAR1 #{scheme (args:get-arg "-target")} [default/ubuntu/nfs] WACKYVAR2 #{runconfigs-get CURRENT} [ubuntu/nfs/none] WACKYVAR2 #{runconfigs-get CURRENT} +SOMEVAR2 This should show up in SOMEVAR4 if the target is ubuntu/nfs/none +VARWITHDOLLARSIGNS The$USER/signs/should/be/replaced/with/variable + +[default] +SOMEVAR3 #{rget SOMEVAR} +SOMEVAR4 #{rget SOMEVAR2} +SOMEVAR5 #{runconfigs-get SOMEVAR2} + +[this/a/test] +BLAHFOO 123 ADDED tests/fullrun/tests/all_toplevel/calcresults.logpro Index: tests/fullrun/tests/all_toplevel/calcresults.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/all_toplevel/calcresults.logpro @@ -0,0 +1,133 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ("exit_0" 1 20) + ("ezlog_fail_then_pass" 1 20) + ("ezlog_pass" 1 20) + ("ez_pass" 1 20) + ("lineitem_pass" 1 20) + ("priority_1" 1 20) + ("priority_10" 1 20) + ("priority_10_waiton_1" 1 20) + ("priority_3" 1 20) + ("priority_4" 1 20) + ("priority_5" 1 20) + ("priority_6" 1 20) + ("priority_7" 1 20) + ("priority_8" 1 20) + ("priority_9" 1 20) + ("runfirst" 7 20) + ("singletest" 1 20) + ("singletest2" 1 20) + ("special" 1 20) + ("sqlitespeed" 10 20) + ("test1" 1 20) + ("test2" 6 20) + ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ("exit_1" 1 20) + ("ez_exit2_fail" 1 20) + ("ez_fail" 1 20) + ("ez_fail_quick" 1 20) + ("ezlog_fail" 1 20) + ("lineitem_fail" 1 20) + ("logpro_required_fail" 1 20) + ("manual_example" 1 20) + ("neverrun" 1 20))) + +(define warn-specs '(("ezlog_warn" 1 20))) +(define nost-specs '(("wait_no_items1" 1 20) + ("wait_no_items2" 1 20) + ("wait_no_items3" 1 20) + ("wait_no_items4" 1 20) + ("no_items" 1 20))) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +(expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: FAIL/) +(expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +(expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "n/a" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,8 +1,13 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET [requirements] -waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars +waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ + ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ + manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 \ + priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ + priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ + ez_fail_quick test1 test2 special blocktestxz # This is a "toplevel" test, it does not require waitons to be non-FAIL to run mode toplevel ADDED tests/fullrun/tests/blocktestxz/main.sh Index: tests/fullrun/tests/blocktestxz/main.sh ================================================================== --- /dev/null +++ tests/fullrun/tests/blocktestxz/main.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +$MT_MEGATEST -test-status :state $THESTATE :status $THESTATUS -setlog "nada.html" + +# By exiting with non-zero we tell Megatest to preseve the state and status +exit 1 ADDED tests/fullrun/tests/blocktestxz/testconfig Index: tests/fullrun/tests/blocktestxz/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/blocktestxz/testconfig @@ -0,0 +1,22 @@ +[setup] +runscript main.sh + +[items] +THESTATE UNKNOWN INCOMPLETE KILLED KILLREQ STUCK BOZZLEBLONKED STUCK/DEAD +THESTATUS PASS FAIL STUCK/DEAD SKIP + +[requirements] +waiton sqlitespeed + +[test_meta] +author matt +owner bob +description This test will fail causing the dependent test "testxz"\ + to never run. This triggers the code that must determine\ + that a test will never be run and thus remove it from\ + the queue of tests to be run. + +tags first,single +reviewed 1/1/1965 + +jobgroup blockz Index: tests/fullrun/tests/exit_0/testconfig ================================================================== --- tests/fullrun/tests/exit_0/testconfig +++ tests/fullrun/tests/exit_0/testconfig @@ -6,5 +6,10 @@ owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single reviewed 09/10/2011, by Matt + +[triggers] +NOT_STARTED/ xterm -e bash -s -- +RUNNING/ xterm -e bash -s -- + Index: tests/fullrun/tests/ez_exit2_fail/testconfig ================================================================== --- tests/fullrun/tests/ez_exit2_fail/testconfig +++ tests/fullrun/tests/ez_exit2_fail/testconfig @@ -5,11 +5,11 @@ lookithome ls /home [test_meta] author matt owner bob -description This test runs two steps; the first exits with - code 2 (a fail because not using logpro) and the second - is a pass +description This test runs two steps; the first exits with\ + code 2 (a fail because not using logpro) and the second\ + is a pass tags first,single reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/ez_fail_quick/testconfig Index: tests/fullrun/tests/ez_fail_quick/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/ez_fail_quick/testconfig @@ -0,0 +1,18 @@ +[requirements] +priority 10 + +[ezsteps] +# should fail on next step +lookitnada ls /nada + +[triggers] +# run like this: cmd test-id test-rundir trigger +COMPLETED/FAIL xterm;echo + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which fails immediately. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/ezlog_fail_then_pass/testconfig ================================================================== --- tests/fullrun/tests/ezlog_fail_then_pass/testconfig +++ tests/fullrun/tests/ezlog_fail_then_pass/testconfig @@ -4,10 +4,10 @@ firststep main.sh [test_meta] author matt owner bob -description This test runs a single ezstep which is logpro clean - but fails based on -test-data loaded. +description This test runs a single ezstep which is logpro clean\ + but fails based on -test-data loaded. tags first,single reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/manual_example/testconfig ================================================================== --- tests/fullrun/tests/manual_example/testconfig +++ tests/fullrun/tests/manual_example/testconfig @@ -5,9 +5,9 @@ # launch launchxterm [test_meta] author matt owner bob -description This test runs a single ezstep which is expected to pass - using a simple logpro file. +description This test runs a single ezstep which is expected to pass\ + using a simple logpro file. tags first,single reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/no_items/testconfig Index: tests/fullrun/tests/no_items/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/no_items/testconfig @@ -0,0 +1,15 @@ +[ezsteps] +listfiles ls + +[items] +FOO + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -3,10 +3,11 @@ [requirements] priority 1 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_2/main.sh ================================================================== --- tests/fullrun/tests/priority_2/main.sh +++ tests/fullrun/tests/priority_2/main.sh @@ -1,10 +1,10 @@ #!/bin/bash # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html - sleep 2 + sleep 5 $MT_MEGATEST -step step$i :state end :status 0 done exit 0 Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -1,12 +1,15 @@ [setup] runscript main.sh [requirements] priority 2 +# runtimelim 1d 1h 1m 10s +runtimelim 20s [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_3/main.sh ================================================================== --- tests/fullrun/tests/priority_3/main.sh +++ tests/fullrun/tests/priority_3/main.sh @@ -2,10 +2,11 @@ # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html sleep 2 + echo "
Results$i
Nothing but faux results here!" > results$i.html $MT_MEGATEST -step step$i :state end :status 0 done # get a previous test export EZFAILPATH=`$MT_MEGATEST -test-files lookithome.log -target $MT_TARGET :runname $MT_RUNNAME -testpatt ez_fail` Index: tests/fullrun/tests/priority_3/testconfig ================================================================== --- tests/fullrun/tests/priority_3/testconfig +++ tests/fullrun/tests/priority_3/testconfig @@ -4,10 +4,11 @@ [requirements] priority 3 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_4/testconfig ================================================================== --- tests/fullrun/tests/priority_4/testconfig +++ tests/fullrun/tests/priority_4/testconfig @@ -3,10 +3,11 @@ [requirements] priority 4 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_5/testconfig ================================================================== --- tests/fullrun/tests/priority_5/testconfig +++ tests/fullrun/tests/priority_5/testconfig @@ -2,10 +2,13 @@ runscript main.sh [requirements] priority 5 +[skip] +prevrunning #t + [test_meta] author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS Index: tests/fullrun/tests/priority_8/main.sh ================================================================== --- tests/fullrun/tests/priority_8/main.sh +++ tests/fullrun/tests/priority_8/main.sh @@ -1,10 +1,14 @@ #!/bin/bash # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do + echo "start step before $i: `date`" $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html + echo "start step after $i: `date`" sleep 2 + echo "end step before $i: `date`" $MT_MEGATEST -step step$i :state end :status 0 + echo "end step after $i: `date`" done exit 0 Index: tests/fullrun/tests/runfirst/main.sh ================================================================== --- tests/fullrun/tests/runfirst/main.sh +++ tests/fullrun/tests/runfirst/main.sh @@ -23,9 +23,16 @@ $MT_MEGATEST -load-test-data << EOF cat, var, val, exp, comp, units, comment, status, type ameas,iout,1.2,1.9,>,Amps,Comment,,meas EOF +loadstatus=$? + +if [[ `basename $PWD` == "mustfail" ]];then + $MT_MEGATEST -test-status :state COMPLETED :status FAIL +else + $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" +fi -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" +env > envfile.txt # $MT_MEGATEST -test-status :state COMPLETED :status FAIL Index: tests/fullrun/tests/runfirst/testconfig ================================================================== --- tests/fullrun/tests/runfirst/testconfig +++ tests/fullrun/tests/runfirst/testconfig @@ -6,19 +6,19 @@ # host. This can be used to control remote launch tools, e.g. to # to choose the target host, select the launch tool etc. SPECIAL_ENV_VAR override with everything after the first space. [items] -SEASON summer winter fall spring +SEASON summer winter fall spring [itemstable] BLOCK a b TOCK 1 2 [test_meta] author matt owner bob -description This test must +description This test must\ be run before the other tests tags first,single reviewed 1/1/1965 Index: tests/fullrun/tests/singletest/main.sh ================================================================== --- tests/fullrun/tests/singletest/main.sh +++ tests/fullrun/tests/singletest/main.sh @@ -2,8 +2,8 @@ # megatest -step wasting_time :state start :status n/a -m "This is a test step comment" # sleep 20 # megatest -step wasting_time :state end :status $? -$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all done eh?" -m "This is a test step comment" +$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo alldone" -m "This is a test step comment" $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_err "This is the first error" ADDED tests/fullrun/tests/special/testconfig Index: tests/fullrun/tests/special/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/special/testconfig @@ -0,0 +1,8 @@ +[ezsteps] +# calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET + +[requirements] +waiton #{rget TESTSTORUN} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +mode toplevel Index: tests/fullrun/tests/sqlitespeed/runscript.rb ================================================================== --- tests/fullrun/tests/sqlitespeed/runscript.rb +++ tests/fullrun/tests/sqlitespeed/runscript.rb @@ -1,8 +1,8 @@ #! /usr/bin/env ruby -require "#{ENV['MT_RUN_AREA_HOME']}/../supportfiles/ruby/librunscript.rb" +require "#{ENV['MT_RUN_AREA_HOME']}/../resources/ruby/librunscript.rb" # run_record(stepname, cmd) - will record in db if exit code of script was zero or not run_and_record('create db',"sqlite3 testing.db << EOF\ncreate table if not exists blah(id INTEGER PRIMARY KEY,name TEXT);\n.q\nEOF","") if (! File.exists?("../../runfirst/I_was_here")) Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -7,5 +7,7 @@ [items] MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED +[test_meta] +jobgroup sqlite3 Index: tests/fullrun/tests/test_mt_vars/currentisblah.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/currentisblah.sh +++ tests/fullrun/tests/test_mt_vars/currentisblah.sh @@ -1,3 +1,3 @@ #!/usr/bin/env bash -grep CURRENT megatest.sh | grep /tmp/nada +grep -e '^export CURRENT' megatest.sh | grep /tmp/nada ADDED tests/fullrun/tests/test_mt_vars/eval_vars.sh Index: tests/fullrun/tests/test_mt_vars/eval_vars.sh ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/eval_vars.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +if env | grep VARWITHDOLLARSIGNS | grep USER;then + exit 1 # fails! +else + exit 0 # good! +fi Index: tests/fullrun/tests/test_mt_vars/testconfig ================================================================== --- tests/fullrun/tests/test_mt_vars/testconfig +++ tests/fullrun/tests/test_mt_vars/testconfig @@ -18,10 +18,13 @@ # VACKYVAR should be set to a path vackyvar vackyvar.sh # test-path and test-file test-path test-path-file.sh + +# verify that vars with $ signs get expanded +varwithdollar eval_vars.sh [requirements] waiton runfirst priority 0 ADDED tests/fullrun/tests/testxz/testconfig Index: tests/fullrun/tests/testxz/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/testxz/testconfig @@ -0,0 +1,15 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +listfiles ls + +# Test requirements are specified here +[requirements] +waiton blocktestxz + +# test_meta is a section for storing additional data on your test +[test_meta] +author mrwellan +owner mrwellan +description This test should never get run due to blocktestxz failing +tags tagone,tagtwo +reviewed never ADDED tests/fullrun/tests/wait_no_items1/testconfig Index: tests/fullrun/tests/wait_no_items1/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items1/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton no_items + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items2/testconfig Index: tests/fullrun/tests/wait_no_items2/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items2/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items1 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items3/testconfig Index: tests/fullrun/tests/wait_no_items3/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items3/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items2 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items4/testconfig Index: tests/fullrun/tests/wait_no_items4/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items4/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items3 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/installall/config/megatest.config.dat Index: tests/installall/config/megatest.config.dat ================================================================== --- /dev/null +++ tests/installall/config/megatest.config.dat @@ -0,0 +1,1 @@ +../megatest.config ADDED tests/installall/config/runconfigs.config.dat Index: tests/installall/config/runconfigs.config.dat ================================================================== --- /dev/null +++ tests/installall/config/runconfigs.config.dat @@ -0,0 +1,1 @@ +../runconfigs.config ADDED tests/installall/config/sheet-names.cfg Index: tests/installall/config/sheet-names.cfg ================================================================== --- /dev/null +++ tests/installall/config/sheet-names.cfg @@ -0,0 +1,2 @@ +megatest.config +runconfigs.config ADDED tests/installall/config/sxml/_sheets.sxml Index: tests/installall/config/sxml/_sheets.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/_sheets.sxml @@ -0,0 +1,51 @@ +((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-21T23:45:07Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-21T23:42:35Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "megatest.config") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "runconfigs.config")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))) ADDED tests/installall/config/sxml/_workbook.sxml Index: tests/installall/config/sxml/_workbook.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/_workbook.sxml @@ -0,0 +1,1 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) ADDED tests/installall/config/sxml/megatest.config.sxml Index: tests/installall/config/sxml/megatest.config.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/megatest.config.sxml @@ -0,0 +1,108 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "5") + (http://www.gnumeric.org/v10.dtd:MaxRow "7") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"megatest.config\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "112.5") (No "0") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "63.75") (No "2") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "3"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "86.25") (No "4") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "5")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.75") (No "0") (Count "8")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) ADDED tests/installall/config/sxml/runconfigs.config.sxml Index: tests/installall/config/sxml/runconfigs.config.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/runconfigs.config.sxml @@ -0,0 +1,111 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "7") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"runconfigs.config\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "108.8") (No "0") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "97.5") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "100.5") (No "2") (HardSize "1") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (Count "2"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "2"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "3") (Count "2"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "5"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "13.5") (No "6"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "7")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "7") (CursorCol "3")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "7") (startCol "3") (endRow "7") (endCol "3")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) ADDED tests/installall/configs/chicken-4.8.0.4.config Index: tests/installall/configs/chicken-4.8.0.4.config ================================================================== --- /dev/null +++ tests/installall/configs/chicken-4.8.0.4.config @@ -0,0 +1,1 @@ +CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz ADDED tests/installall/configs/chicken-4.8.1.config Index: tests/installall/configs/chicken-4.8.1.config ================================================================== --- /dev/null +++ tests/installall/configs/chicken-4.8.1.config @@ -0,0 +1,1 @@ +CHICKEN_URL http://code.call-cc.org/dev-snapshots/2013/01/04/chicken-4.8.1.tar.gz ADDED tests/installall/megatest.config Index: tests/installall/megatest.config ================================================================== --- /dev/null +++ tests/installall/megatest.config @@ -0,0 +1,24 @@ +[fields] +CHICKEN_VERSION TEXT +MEGATEST_VERSION TEXT +IUPMODE TEXT +BUILD_TAG TEXT + +[setup] +max_concurrent_jobs 6 +linktree #{getenv MT_RUN_AREA_HOME}/links +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log + +[jobtools] +useshell yes +launcher nbfind + +[env-override] +EXAMPLE_VAR example value + +[server] +port 9080 + +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/runs + ADDED tests/installall/runconfigs.config Index: tests/installall/runconfigs.config ================================================================== --- /dev/null +++ tests/installall/runconfigs.config @@ -0,0 +1,38 @@ +[.............] +# +# [CHICKEN_VERSION/MEGATEST_VERSION/IUPMODE/PLATFORM/BUILD_TAG] +# + +[default] +ALLTESTS see this variable +PREFIX #{getenv MT_RUN_AREA_HOME}/#{getenv BUILD_TAG}/#{getenv MT_RUNNAME} +DOWNLOADS #{getenv MT_RUN_AREA_HOME}/downloads +IUPLIB 26g4 +PLATFORM linux +LOGPRO_VERSION v1.05 +BUILDSQLITE yes +SQLITE3_VERSION 3071401 +ZEROMQ_VERSION 2.2.0 +logpro_VERSION v1.08 +stml_VERSION v0.901 +megatest_VERSION v1.5511 + +[include configs/hicken-#{getenv CHICKEN_VERSION}.config] + +# Currently must have at least one variable in a section +[4.8.0/trunk/bin/std] +IUP_VERSION na + +[4.8.0.4/trunk/src/std] +CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz +IUP_VERSION na + +[4.8.1/trunk/src/std] +IUP_VERSION na + +[4.8.0/v1.5508/opt] +IUP_VERSION na +PREFIX /opt/chicken/4.8.0 + +[4.8.0/trunk/centos5.7vm] +BUILDSQLITE no ADDED tests/installall/tests/canvas-draw/install.logpro Index: tests/installall/tests/canvas-draw/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/canvas-draw/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/canvas-draw/install.sh Index: tests/installall/tests/canvas-draw/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/canvas-draw/install.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/canvas-draw/testconfig Index: tests/installall/tests/canvas-draw/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/canvas-draw/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton iuplib setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the canvas-draw egg +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/chicken/compile.logpro Index: tests/installall/tests/chicken/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/chicken/compile.logpro @@ -0,0 +1,10 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory ..." #/Leaving directory/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:ignore in "LogFileBody" >= 0 "Ignore HAVE_STRERROR" #/HAVE_STRERROR/) + +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/chicken/compile.sh Index: tests/installall/tests/chicken/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/chicken/compile.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd chicken-${CHICKEN_VERSION} +make PLATFORM=${PLATFORM} PREFIX=${PREFIX} ADDED tests/installall/tests/chicken/download.logpro Index: tests/installall/tests/chicken/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/chicken/download.logpro @@ -0,0 +1,11 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "README file must be seen" #/README$/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + +(expect:ignore in "LogFileBody" >= 0 "Ignore error flagged by finalizer-error-test" #/\w+-error/) + +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/chicken/download.sh Index: tests/installall/tests/chicken/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/chicken/download.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +if [ ! -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]; then + if [ "${CHICKEN_URL}" == "" ]; then + CHICKEN_URL=http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz + fi + echo "Downloading $CHICKEN_URL" + (cd ${DOWNLOADS};wget ${CHICKEN_URL}) +fi + +ls -l ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz + +tar xfvz ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz + +ls -l chicken-${CHICKEN_VERSION} ADDED tests/installall/tests/chicken/install.logpro Index: tests/installall/tests/chicken/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/chicken/install.logpro @@ -0,0 +1,11 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + +(expect:ignore in "LogFileBody" >= 0 "Ignore error in some filenames" #/\w+-errors/) + +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/chicken/install.sh Index: tests/installall/tests/chicken/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/chicken/install.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh +# source $PREFIX + +cd chicken-${CHICKEN_VERSION} +make PLATFORM=${PLATFORM} PREFIX=${PREFIX} install + +ls -l ${PREFIX}/bin ADDED tests/installall/tests/chicken/testconfig Index: tests/installall/tests/chicken/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/chicken/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +compile compile.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton setup +# priority 10 + +# Iteration for your tests are controlled by the items section +[items] +# CHICKEN_VERSION 4.8.0 + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install chicken scheme +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/eggs/install.logpro Index: tests/installall/tests/eggs/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/eggs/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Last thing done is chmod ..." #/chmod /) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore someword-errors" #/\w+-error/) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/eggs/install.sh Index: tests/installall/tests/eggs/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/eggs/install.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +$PREFIX/bin/chicken-install $PROX $EGG_NAME + ADDED tests/installall/tests/eggs/testconfig Index: tests/installall/tests/eggs/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/eggs/testconfig @@ -0,0 +1,20 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton chicken setup +priority 9 + +# Iteration for your tests are controlled by the items section +[items] +EGG_NAME matchable readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 ssax sxml-serializer sxml-modifications salmonella sql-de-lite postgresql + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install eggs with no significant prerequisites +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/ffcall/compile.logpro Index: tests/installall/tests/ffcall/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/compile.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/ffcall/compile.sh Index: tests/installall/tests/ffcall/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/compile.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd ffcall +./configure --prefix=${PREFIX} --enable-shared +make ADDED tests/installall/tests/ffcall/download.logpro Index: tests/installall/tests/ffcall/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "VERSION" #/ VERSION/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/ffcall/download.sh Index: tests/installall/tests/ffcall/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/download.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +if ! [[ -e ${DOWNLOADS}/ffcall.tar.gz ]] ; then + (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz ) +fi + +tar xfvz ${DOWNLOADS}/ffcall.tar.gz + +ls -l ffcall ADDED tests/installall/tests/ffcall/install.logpro Index: tests/installall/tests/ffcall/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/ffcall/install.sh Index: tests/installall/tests/ffcall/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/install.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd ffcall +make install ADDED tests/installall/tests/ffcall/testconfig Index: tests/installall/tests/ffcall/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/testconfig @@ -0,0 +1,20 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +compile compile.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the ffcall library +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iup/install.logpro Index: tests/installall/tests/iup/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iup/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "chmod is roughly last thing that happens" #/chmod /) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore setup-error-handling" #/\w+-error/) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iup/install.sh Index: tests/installall/tests/iup/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/iup/install.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +# source $PREFIX/setup-chicken4x.sh + +export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` +CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $PREFIX/bin/chicken-install $PROX -D no-library-checks -feature disable-iup-web iup +# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup +# iup:1.0.2 +CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $PREFIX/bin/chicken-install $PROX -D no-library-checks canvas-draw +# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw ADDED tests/installall/tests/iup/testconfig Index: tests/installall/tests/iup/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/iup/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton iup#{getenv IUPMODE}lib tougheggs + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install iup egg +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iupbinlib/compile.logpro Index: tests/installall/tests/iupbinlib/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/compile.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/compile.sh Index: tests/installall/tests/iupbinlib/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/compile.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/iupbinlib/download.logpro Index: tests/installall/tests/iupbinlib/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "README file should show up" #/README/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/download.sh Index: tests/installall/tests/iupbinlib/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/download.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +# source $PREFIX/setup-chicken4x.sh + +if [[ `uname -a | grep x86_64` == "" ]]; then + export ARCHSIZE='' +else + export ARCHSIZE=64_ +fi + # export files="cd-5.4.1_Linux${IUPLIB}_lib.tar.gz im-3.6.3_Linux${IUPLIB}_lib.tar.gz iup-3.5_Linux${IUPLIB}_lib.tar.gz" +if [[ x$USEOLDIUP == "x" ]];then + export files="cd-5.5.1_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz im-3.8_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz iup-3.6_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz" +else + echo WARNING: Using old IUP libraries + export files="cd-5.4.1_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz" +fi + +mkdir -p $PREFIX/iuplib +for a in `echo $files` ; do + if ! [[ -e ${DOWNLOADS}/$a ]] ; then + (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/$a) + fi + echo Untarring $a into $PREFIX/lib + (cd $PREFIX/lib;tar xfvz ${DOWNLOADS}/$a;mv include/* ../include) +done + ADDED tests/installall/tests/iupbinlib/install.logpro Index: tests/installall/tests/iupbinlib/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/install.sh Index: tests/installall/tests/iupbinlib/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/install.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/iupbinlib/testconfig Index: tests/installall/tests/iupbinlib/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh + +# Test requirements are specified here +[requirements] +waiton ffcall setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the iup library if it is not already installed +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iupbinlib/untar.logpro Index: tests/installall/tests/iupbinlib/untar.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/untar.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/untar.sh Index: tests/installall/tests/iupbinlib/untar.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/untar.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/iupsrclib/cd.logpro Index: tests/installall/tests/iupsrclib/cd.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/cd.logpro @@ -0,0 +1,3 @@ +(expect:ignore in "LogFileBody" >= 0 "Ignore these binary operator errors for now" #/error: missing binary operator/) + +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/compile.logpro Index: tests/installall/tests/iupsrclib/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/compile.logpro @@ -0,0 +1,12 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Completed signature" #/(Dynamic Library.*Done|Leaving directory|Nothing to be done)/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore files with error in name" #/error.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with errors in name" #/errors.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with warn in name" #/warning.[ch]/) + +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/compile.sh Index: tests/installall/tests/iupsrclib/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/compile.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +# Run your step here + +pkg=$1 + +source $PREFIX/buildsetup.sh + +export LUA_SUFFIX= +export LUA_INC=$MT_TEST_RUN_DIR/lua52/include + +if [[ $pkg == "lua52" ]]; then + (cd $pkg/src;make $PLATFORM) +else + (cd $pkg/src;make) +fi + ADDED tests/installall/tests/iupsrclib/download.logpro Index: tests/installall/tests/iupsrclib/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/download.logpro @@ -0,0 +1,13 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "README file should show up" #/README/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + +(expect:ignore in "LogFileBody" >= 0 "Ignore files with error in name" #/error.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with errors in name" #/errors.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with warn in name" #/warning.[ch]/) + +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/download.sh Index: tests/installall/tests/iupsrclib/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/download.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +mkdir -p $PREFIX/iuplib +for a in cd-5.6.1_Sources.tar.gz im-3.8.1_Sources.tar.gz iup-3.8_Sources.tar.gz lua-5.2.1_Sources.tar.gz; do + if ! [[ -e ${DOWNLOADS}/$a ]] ; then + (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/$a) + fi + tar xfvz ${DOWNLOADS}/$a +done + +find . -type d -exec chmod ug+x {} \; ADDED tests/installall/tests/iupsrclib/im.logpro Index: tests/installall/tests/iupsrclib/im.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/im.logpro @@ -0,0 +1,1 @@ +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/install.logpro Index: tests/installall/tests/iupsrclib/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/install.sh Index: tests/installall/tests/iupsrclib/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/install.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +# The so files +cp -f im/lib/Linux26g4/*.so $PREFIX/lib +cp -f cd/lib/Linux26g4/*.so $PREFIX/lib +cp -f iup/lib/Linux26g4/*.so $PREFIX/lib + +# The development files +mkdir -p $PREFIX/include/im +cp -fR im/include/*.h $PREFIX/include/im +cp -f im/lib/Linux26g4/*.a $PREFIX/lib + +mkdir -p $PREFIX/include/cd +cp -f cd/include/*.h $PREFIX/include/cd +cp -f cd/lib/Linux26g4/*.a $PREFIX/lib + +mkdir -p /usr/include/iup +cp -f iup/include/*.h $PREFIX/include/iup +cp -f iup/lib/Linux26g4/*.a $PREFIX/lib ADDED tests/installall/tests/iupsrclib/iup.logpro Index: tests/installall/tests/iupsrclib/iup.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/iup.logpro @@ -0,0 +1,3 @@ +(expect:ignore in "LogFileBody" >= 0 "Ignore these binary operator errors for now" #/error: missing binary operator/ expires: "10/10/2013") + +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/lua.logpro Index: tests/installall/tests/iupsrclib/lua.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/lua.logpro @@ -0,0 +1,1 @@ +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/testconfig Index: tests/installall/tests/iupsrclib/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +lua compile.sh lua52 +im compile.sh im +cd compile.sh cd +iup compile.sh iup + +# Test requirements are specified here +[requirements] +waiton ffcall setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the iup library if it is not already installed +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iupsrclib/untar.logpro Index: tests/installall/tests/iupsrclib/untar.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/untar.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/untar.sh Index: tests/installall/tests/iupsrclib/untar.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/untar.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/mmisc/clone.logpro Index: tests/installall/tests/mmisc/clone.logpro ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/clone.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Output from fossil" #/^repository:\s+/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/mmisc/clone.sh Index: tests/installall/tests/mmisc/clone.sh ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/clone.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +fossil clone http://www.kiatoa.com/fossils/$FSLPKG $FSLPKG.fossil + +mkdir src +cd src +fossil open ../$FSLPKG.fossil --nested +fossil co ${$FSLPKG}_VERSION} ADDED tests/installall/tests/mmisc/install.logpro Index: tests/installall/tests/mmisc/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Always get a chmod at the end of install" #/chmod.*logpro.setup-info/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in setup-error-handling" #/setup-error-handling/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/mmisc/install.sh Index: tests/installall/tests/mmisc/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/install.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +cd src +if [ $FSLPKG == "logpro" ];then + chicken-install +elif [ $FSLPKG == "stml" ];then + cp install.cfg.template install.cfg + cp requirements.scm.template requirements.scm + make + make install +else + make + make install PREFIX=$PREFIX +fi ADDED tests/installall/tests/mmisc/testconfig Index: tests/installall/tests/mmisc/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/testconfig @@ -0,0 +1,21 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +clone clone.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton eggs setup + +# Iteration for your tests are controlled by the items section +[items] +FSLPKG logpro stml megatest + + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the logpro tool +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/opensrc/clone.logpro Index: tests/installall/tests/opensrc/clone.logpro ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/clone.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Output from fossil" (list #/^repository:\s+/ #/comment:/)) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/opensrc/clone.sh Index: tests/installall/tests/opensrc/clone.sh ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/clone.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +parentdir=$MT_LINKTREE/$MT_TARGET/$MT_RUNNAME + +lockfile $parentdir/clone.lock +if [ ! -e $parentdir/opensrc.fossil ];then + fossil clone http://www.kiatoa.com/fossils/opensrc $parentdir/opensrc.fossil +fi + +if [ ! -e $parentdir/src/dbi ];then + mkdir -p $parentdir/src + (cd $parentdir/src;fossil open $parentdir/opensrc.fossil --nested) +else + (cd $parentdir/src;fossil sync;fossil co trunk;fossil status) +fi +rm -f $parentdir/clone.lock + +ln -sf $parentdir/src $MT_TEST_RUN_DIR/src + ADDED tests/installall/tests/opensrc/install.logpro Index: tests/installall/tests/opensrc/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Always get a chmod at the end of install" #/chmod.*.setup-info/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in setup-error-handling" #/setup-error-handling/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/opensrc/install.sh Index: tests/installall/tests/opensrc/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/install.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +cd src/$MODULE_NAME +chicken-install ADDED tests/installall/tests/opensrc/testconfig Index: tests/installall/tests/opensrc/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/testconfig @@ -0,0 +1,20 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +clone clone.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton eggs setup sqlite3 + +# Iteration for your tests are controlled by the items section +[items] +MODULE_NAME dbi margs qtree vcd xfig mutils + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the eggs from the opensrc fossil +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/setup/setup.logpro Index: tests/installall/tests/setup/setup.logpro ================================================================== --- /dev/null +++ tests/installall/tests/setup/setup.logpro @@ -0,0 +1,10 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "ALL DONE" #/ALL DONE$/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + + +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/setup/setup.sh Index: tests/installall/tests/setup/setup.sh ================================================================== --- /dev/null +++ tests/installall/tests/setup/setup.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash + +# Run your step here + +cksetupsh=$PREFIX/setup-chicken4x.sh +cksetupcsh=$PREFIX/setup-chicken4x.csh +setupsh=$PREFIX/buildsetup.sh + +# make a cache dir +mkdir -p $DOWNLOADS +mkdir -p $PREFIX + +# File for users to source to run chicken +echo "# Source me to setup to to run chicken" > $cksetupsh +echo "export PATH=$PREFIX/bin:\$PATH" > $cksetupsh +echo "export LD_LIBRARY_PATH=$PREFIX/lib" >> $cksetupsh + +# tcsh version +echo "setenv PATH $PREFIX/bin:\$PATH" > $cksetupcsh +echo "setenv LD_LIBRARY_PATH $PREFIX/lib" >> $cksetupcsh + +# File to source for build process +echo "export PATH=$PREFIX/bin:\$PATH" > $setupsh +echo "export LD_LIBRARY_PATH=$PREFIX/lib" >> $setupsh + +if [[ $proxy == "" ]]; then + echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' +else + echo "export http_proxy=http://$proxy" >> $setupsh + echo "export PROX=\"-proxy $proxy\"" >> $setupsh +fi + +echo "export PREFIX=$PREFIX" >> $setupsh + +echo ALL DONE ADDED tests/installall/tests/setup/testconfig Index: tests/installall/tests/setup/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/setup/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +setup setup.sh + +# Test requirements are specified here +[requirements] +# priority 10 + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install chicken scheme +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/sqlite3/compile.logpro Index: tests/installall/tests/sqlite3/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/compile.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/(Leaving directory|Nothing to be done for|creating sqlite3)/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore strerror_r" #/strerror_r/i) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/compile.sh Index: tests/installall/tests/sqlite3/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/compile.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd sqlite-autoconf-$SQLITE3_VERSION +./configure --prefix=$PREFIX + +make ADDED tests/installall/tests/sqlite3/download.logpro Index: tests/installall/tests/sqlite3/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "sqlite-autoconf" #/sqlite-autoconf/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/download.sh Index: tests/installall/tests/sqlite3/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/download.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +echo Install sqlite3 +if ! [[ -e ${DOWNLOADS}/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz ]]; then + (cd ${DOWNLOADS};wget http://www.sqlite.org/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz) +fi + +tar xfz ${DOWNLOADS}/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz + +ls -l sqlite-autoconf-${SQLITE3_VERSION}.tar.gz ADDED tests/installall/tests/sqlite3/install.logpro Index: tests/installall/tests/sqlite3/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/install.sh Index: tests/installall/tests/sqlite3/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/install.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd sqlite-autoconf-$SQLITE3_VERSION +make install + ADDED tests/installall/tests/sqlite3/installegg.logpro Index: tests/installall/tests/sqlite3/installegg.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/installegg.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "chmod sqlite3" #/chmod.*sqlite3/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore setup-error-handling" #/setup-error-handling/) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/installegg.sh Index: tests/installall/tests/sqlite3/installegg.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/installegg.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $PREFIX/bin/chicken-install $PROX sqlite3 ADDED tests/installall/tests/sqlite3/testconfig Index: tests/installall/tests/sqlite3/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/testconfig @@ -0,0 +1,24 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +compile compile.sh +install install.sh +installegg installegg.sh + +# Test requirements are specified here +[requirements] +# We waiton chicken because this one installs the egg. It would behove us to split this +# into two tests ... +waiton tougheggs +priority 2 + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install sqlite3 library for systems where it is not installed +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/tougheggs/install.logpro Index: tests/installall/tests/tougheggs/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/tougheggs/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Last thing done is chmod ..." #/chmod /) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore someword-errors" #/\w+-error/) +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/tougheggs/install.sh Index: tests/installall/tests/tougheggs/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/tougheggs/install.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +lockfile $PREFIX/eggs.lock +$PREFIX/bin/chicken-install $PROX $EGG_NAME +rm -f $PREFIX/eggs.lock ADDED tests/installall/tests/tougheggs/testconfig Index: tests/installall/tests/tougheggs/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/tougheggs/testconfig @@ -0,0 +1,19 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton eggs + +# Iteration for your tests are controlled by the items section +[items] +EGG_NAME intarweb http-client awful uri-common spiffy-request-vars spiffy apropos spiffy-directory-listing + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install eggs with no significant prerequisites +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/zmq/install.logpro Index: tests/installall/tests/zmq/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmq/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmq/install.sh Index: tests/installall/tests/zmq/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmq/install.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmq/testconfig Index: tests/installall/tests/zmq/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/zmq/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton zmqlib chicken setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the zmq egg +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/zmqlib/compile.logpro Index: tests/installall/tests/zmqlib/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/compile.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/compile.sh Index: tests/installall/tests/zmqlib/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/compile.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmqlib/download.logpro Index: tests/installall/tests/zmqlib/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/download.sh Index: tests/installall/tests/zmqlib/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/download.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmqlib/install.logpro Index: tests/installall/tests/zmqlib/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/install.sh Index: tests/installall/tests/zmqlib/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/install.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmqlib/testconfig Index: tests/installall/tests/zmqlib/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/testconfig @@ -0,0 +1,21 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +untar untar.sh +compile compile.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the zmq library if it doesn't already exist +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/zmqlib/untar.logpro Index: tests/installall/tests/zmqlib/untar.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/untar.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/untar.sh Index: tests/installall/tests/zmqlib/untar.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/untar.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/mintest/megatest.config Index: tests/mintest/megatest.config ================================================================== --- /dev/null +++ tests/mintest/megatest.config @@ -0,0 +1,17 @@ +[fields] +X TEXT + +[setup] +max_concurrent_jobs 50 +linktree #{getenv PWD}/linktree +transport http + +[server] +port 8090 + +[jobtools] +useshell yes +launcher nbfind + +[disks] +disk0 #{getenv PWD}/runs ADDED tests/mintest/runconfigs.config Index: tests/mintest/runconfigs.config ================================================================== --- /dev/null +++ tests/mintest/runconfigs.config @@ -0,0 +1,6 @@ +[default] +ALLTESTS see this variable + +# Your variables here are grouped by targets [SYSTEM/RELEASE] +[a] +ANOTHERVAR only defined if target is "a" ADDED tests/mintest/tests/a/testconfig Index: tests/mintest/tests/a/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/a1/testconfig Index: tests/mintest/tests/a1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b1 ADDED tests/mintest/tests/b/testconfig Index: tests/mintest/tests/b/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c ADDED tests/mintest/tests/b1/testconfig Index: tests/mintest/tests/b1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c1 ADDED tests/mintest/tests/c/testconfig Index: tests/mintest/tests/c/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d ADDED tests/mintest/tests/c1/testconfig Index: tests/mintest/tests/c1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d1fail ADDED tests/mintest/tests/d/testconfig Index: tests/mintest/tests/d/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton e ADDED tests/mintest/tests/d1fail/testconfig Index: tests/mintest/tests/d1fail/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d1fail/testconfig @@ -0,0 +1,7 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS +step2 exit 123 + +[requirements] +waiton e1 ADDED tests/mintest/tests/e/testconfig Index: tests/mintest/tests/e/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e/testconfig @@ -0,0 +1,4 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + ADDED tests/mintest/tests/e1/testconfig Index: tests/mintest/tests/e1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e1/testconfig @@ -0,0 +1,4 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + ADDED tests/mintest/tests/f/testconfig Index: tests/mintest/tests/f/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/f/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton ADDED tests/mintest/tests/g/testconfig Index: tests/mintest/tests/g/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/g/testconfig @@ -0,0 +1,9 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b + +[items] +NADA ADDED tests/mintest/tests/h/testconfig Index: tests/mintest/tests/h/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/h/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/i/testconfig Index: tests/mintest/tests/i/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/i/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/j/testconfig Index: tests/mintest/tests/j/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/j/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/k/testconfig Index: tests/mintest/tests/k/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/k/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/l/testconfig Index: tests/mintest/tests/l/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/l/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/resources/ruby/librunscript.rb Index: tests/resources/ruby/librunscript.rb ================================================================== --- /dev/null +++ tests/resources/ruby/librunscript.rb @@ -0,0 +1,37 @@ +# This is the library of stuff for megatest + +def run_and_record(stepname, cmd, checks) + system "megatest -step #{stepname} :state start :status n/a" + system cmd + exitcode=$? + if exitcode==0 + exitcode='pass' + else + exitcode='fail' + end + system "megatest -step #{stepname} :state end :status #{exitcode}" +end + +def record_step(stepname,state,status) + system "megatest -step #{stepname} :state #{state} :status #{status}" +end + +def test_status(state,status) + system "megatest -test-status :state #{state} :status #{status}" +end + + +# WARNING: This example is deprecated. Don't use the -test-status command +# unless you know for sure what you are doing. +def file_size_checker(stepname,filename,minsize,maxsize) + fsize=File.size(filename) + if fsize > maxsize or fsize < minsize + system "megatest -test-status :state COMPLETED :status fail" + else + system "megatest -test-status :state COMPLETED :status pass" + end +end + + +def wait_for_step(testname,stepname) +end ADDED tests/rununittest.sh Index: tests/rununittest.sh ================================================================== --- /dev/null +++ tests/rununittest.sh @@ -0,0 +1,23 @@ +#!/bin/bash + +# Usage: rununittest.sh testname debuglevel +# + +# Ensure all is made +(cd ..;make && make install) + +# put megatest on path from correct location +mtbindir=$(readlink -f ../bin) + +export PATH="${mtbindir}:$PATH" + +# Clean setup +# +dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db +rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db +rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir +mkdir -p simplelinks simpleruns +(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) + +# Run the test $1 is the unit test to run +cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -3,13 +3,18 @@ RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 + +# Uncomment this to make the in-mem db into a disk based db (slower but good for debug) +# be aware that some unit tests will fail with this due to persistent data +# +# tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable -linktree #{shell readlink -f #{getenv PWD}/../simplelinks} +linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed @@ -22,6 +27,6 @@ [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] -disk0 #{shell readlink -f #{getenv PWD}/../simpleruns} +disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns Index: tests/simplerun/tests/test1/step1.logpro ================================================================== --- tests/simplerun/tests/test1/step1.logpro +++ tests/simplerun/tests/test1/step1.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) Index: tests/simplerun/tests/test1/step1.sh ================================================================== --- tests/simplerun/tests/test1/step1.sh +++ tests/simplerun/tests/test1/step1.sh @@ -1,4 +1,5 @@ #!/usr/bin/env bash # Run your step here echo Got here! + Index: tests/simplerun/tests/test1/step2.logpro ================================================================== --- tests/simplerun/tests/test1/step2.logpro +++ tests/simplerun/tests/test1/step2.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) Index: tests/simplerun/tests/test1/step2.sh ================================================================== --- tests/simplerun/tests/test1/step2.sh +++ tests/simplerun/tests/test1/step2.sh @@ -1,5 +1,6 @@ #!/usr/bin/env bash # Run your step here echo Got here eh! + Index: tests/simplerun/tests/test2/step1.logpro ================================================================== --- tests/simplerun/tests/test2/step1.logpro +++ tests/simplerun/tests/test2/step1.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) ADDED tests/simplerun/tests/test2/step1.sh Index: tests/simplerun/tests/test2/step1.sh ================================================================== --- /dev/null +++ tests/simplerun/tests/test2/step1.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +# Run your step here DELETED tests/simplerun/tests/test2/step1.sh.sh Index: tests/simplerun/tests/test2/step1.sh.sh ================================================================== --- tests/simplerun/tests/test2/step1.sh.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here Index: tests/simplerun/tests/test2/step2.logpro ================================================================== --- tests/simplerun/tests/test2/step2.logpro +++ tests/simplerun/tests/test2/step2.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) ADDED tests/simplerun/tests/test2/step2.sh Index: tests/simplerun/tests/test2/step2.sh ================================================================== --- /dev/null +++ tests/simplerun/tests/test2/step2.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +# Run your step here DELETED tests/simplerun/tests/test2/step2.sh.sh Index: tests/simplerun/tests/test2/step2.sh.sh ================================================================== --- tests/simplerun/tests/test2/step2.sh.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here ADDED tests/speedtest/megatest.config Index: tests/speedtest/megatest.config ================================================================== --- /dev/null +++ tests/speedtest/megatest.config @@ -0,0 +1,48 @@ +[fields] +sysname TEXT +fsname TEXT +datapath TEXT + +[setup] +transport #{scheme (if (getenv "USEHTTP") "http" "fs")} + +max_concurrent_jobs 50 + +# It is possible (but not recommended) to override the rsync command used +# to populate the test directories. For test development the following +# example can be useful +# +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log + +# FULL or 2, NORMAL or 1, OFF or 0 +synchronous OFF + +# override the logview command +# +logviewer (%MTCMD%) 2> /dev/null > /dev/null + +# override the html viewer launch command +# +# htmlviewercmd firefox -new-window +htmlviewercmd konqueror + +[jobtools] +launcher nbfake + +[server] + +# If the server can't be started on this port it will try the next port until +# it succeeds +port 8080 + +# This server will keep running this number of hours after last access. +# Three minutes is 0.05 hours +timeout 0.025 + +## disks are: +## name host:/path/to/area +## -or- +## name /path/to/area +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/tmp_run + ADDED tests/speedtest/runconfigs.config Index: tests/speedtest/runconfigs.config ================================================================== --- /dev/null +++ tests/speedtest/runconfigs.config @@ -0,0 +1,3 @@ +[default] +SOMEVAR This should show up in SOMEVAR3 + ADDED tests/speedtest/tests/speedtest/main.sh Index: tests/speedtest/tests/speedtest/main.sh ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/main.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +# a bunch of steps in 2 second increments +for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do + $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html + sleep $TEST_DELAY + $MT_MEGATEST -step step$i :state end :status 0 +done + +exit 0 ADDED tests/speedtest/tests/speedtest/testconfig Index: tests/speedtest/tests/speedtest/testconfig ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/testconfig @@ -0,0 +1,18 @@ +[setup] +runscript main.sh + +[requirements] +priority 1 + +[items] +SETLOG 0 1 +TEST_DELAY 0 1 2 3 4 5 6 7 8 9 10 +ITERATIONS 0 1 2 3 4 5 6 7 8 9 10 + +[test_meta] +author matt +owner bob +description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/stats.txt Index: tests/stats.txt ================================================================== --- /dev/null +++ tests/stats.txt @@ -0,0 +1,77 @@ +DB Stats: a1236d6bf92ec5cb8955f490761b21b0d3eea9d3 +======== +Cmd Count TotTime Avg +get-count-tests-running-for-run-id 1035 237.0 0.23 +get-count-tests-running-in-jobgroup 884 119.0 0.13 +get-count-tests-running 884 169.0 0.19 +get-prereqs-not-met 884 732.0 0.83 +get-test-info-by-id 673 122.0 0.18 +get-keys 476 1.0 0.00 +get-test-id 356 42.0 0.12 +testmeta-get-record 203 24.0 0.12 +roll-up-pass-fail-counts 159 39.0 0.25 +register-test 140 30.0 0.21 +test-set-rundir-shortdir 128 98.0 0.77 +test-set-status-state 94 45.0 0.48 +find-and-mark-incomplete 32 0.0 0.00 +state-status-msg 25 4.0 0.16 +delete-tests-in-state 12 4.0 0.33 +get-tests-for-run-mindata 8 0.0 0.00 +get-all-run-ids 5 2.0 0.40 +get-run-info 4 0.0 0.00 +register-run 4 5.0 1.25 +set-tests-state-status 4 15.0 3.75 +get-tests-for-run 4 15.0 3.75 + +# After converting first three functions above to sqlite3:first-result +DB Stats +======== +Cmd Count TotTime Avg +get-count-tests-running-for-run-id 1138 179.0 0.16 +get-count-tests-running-in-jobgroup 987 91.0 0.09 +get-count-tests-running 987 171.0 0.17 +get-prereqs-not-met 987 892.0 0.90 +get-test-info-by-id 672 95.0 0.14 +get-keys 476 0.0 0.00 +get-test-id 355 41.0 0.12 +testmeta-get-record 203 15.0 0.07 +roll-up-pass-fail-counts 159 30.0 0.19 +register-test 140 22.0 0.16 +test-set-rundir-shortdir 128 855.0 6.68 +test-set-status-state 94 20.0 0.21 +find-and-mark-incomplete 36 1.0 0.03 +state-status-msg 24 5.0 0.21 +delete-tests-in-state 12 2.0 0.17 +get-tests-for-run-mindata 9 0.0 0.00 +get-all-run-ids 5 1.0 0.20 +register-run 4 1.0 0.25 +get-tests-for-run 4 11.0 2.75 +get-run-info 4 0.0 0.00 +set-tests-state-status 4 17.0 4.25 + +DB Stats another run, converted one or two non-relevant functions to sqlite3:first-result +======== +Cmd Count TotTime Avg +get-count-tests-running-for-run-id 987 157.0 0.16 +get-count-tests-running-in-jobgroup 836 79.0 0.09 +get-count-tests-running 836 121.0 0.14 +get-prereqs-not-met 836 513.0 0.61 +get-test-info-by-id 673 85.0 0.13 +get-keys 476 0.0 0.00 +get-test-id 356 32.0 0.09 +testmeta-get-record 203 19.0 0.09 +roll-up-pass-fail-counts 159 27.0 0.17 +register-test 140 23.0 0.16 +test-set-rundir-shortdir 128 35.0 0.27 +test-set-status-state 94 20.0 0.21 +find-and-mark-incomplete 40 0.0 0.00 +state-status-msg 25 5.0 0.20 +delete-tests-in-state 12 1.0 0.08 +get-tests-for-run-mindata 10 0.0 0.00 +get-all-run-ids 5 0.0 0.00 +set-tests-state-status 4 15.0 3.75 +register-run 4 2.0 0.50 +get-run-info 4 1.0 0.25 +get-tests-for-run 4 12.0 3.00 + + ADDED tests/test7.logpro Index: tests/test7.logpro ================================================================== --- /dev/null +++ tests/test7.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "All tests launched" #/INFO:.*All tests launched/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -11,12 +11,12 @@ (require-extension test) (require-extension regex) (require-extension srfi-18) (import srfi-18) -(require-extension zmq) -(import zmq) +;; (require-extension zmq) +;; (import zmq) (define test-work-dir (current-directory)) ;; read in all the _record files (let ((files (glob "*_records.scm"))) @@ -24,377 +24,17 @@ (lambda (file) (print "Loading " file) (load file)) files)) -(define *runremote* #f) - -;;====================================================================== -;; P R O C E S S E S -;;====================================================================== - -(test "cmd-run-with-stderr->list" '("No such file or directory") - (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist"))) - (string-search (regexp "No such file or directory")(car reslst)))) - -;;====================================================================== -;; T E S T M A T C H I N G -;;====================================================================== - -;; tests:glob-like-match -(test #f '("abc") (tests:glob-like-match "abc" "abc")) -(for-each - (lambda (patt str expected) - (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str))) - (list "abc" "~abc" "~abc" "a*c" "a%c") - (list "abc" "abcd" "abc" "ABC" "ABC") - (list '("abc") #t #f #f '("ABC")) - ) - -;; tests:match -(test #f #t (tests:match "abc/def" "abc" "def")) -(for-each - (lambda (patterns testname itempath expected) - (test (conc patterns " " testname "/" itempath "=>" expected) - expected - (tests:match patterns testname itempath))) - (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/") - (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a") - (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b") - (list #t #t #t #f #f #t #t #t #f #t #t #t #f)) - -;; db:patt->like -(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND ")) -(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND ")) -(test #f "item_path GLOB ''" (db:patt->like "item_path" "")) - -;; test:match->sqlqry -(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" - (tests:match->sqlqry "a/b,a%,/b%")) -(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" - (tests:match->sqlqry "a/b,a%,%/b%")) - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -(test "setup for run" #t (begin (setup-for-run) - (string? (getenv "MT_RUN_AREA_HOME")))) - -(test "server-register, get-best-server" #t (let ((res #f)) - (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live) - (set! res (open-run-close tasks:get-best-server tasks:open-db)) - (number? (cadddr res)))) - -(test "de-register server" #t (let ((res #f)) - (open-run-close tasks:server-deregister tasks:open-db "bob" pullport: 1234) - (list? (open-run-close tasks:get-best-server tasks:open-db)))) - -(define hostinfo #f) -(test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) - (set! hostinfo dat) ;; host ip pullport pubport - (and (string? (car dat)) - (number? (caddr dat))))) - -(test #f #t (let ((zmq-socket (server:client-connect - (cadr hostinfo) - (caddr hostinfo) - ;; (cadddr hostinfo) - ))) - (set! *runremote* zmq-socket) - (string? (car *runremote*)))) - -(test #f #t (let ((res (server:client-login *runremote*))) - (car res))) - -(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*))) - -;;====================================================================== -;; C O N F I G F I L E S -;;====================================================================== - -(define conffile #f) -(test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) -(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) - -(set! conffile (read-config "test.config" #f #f)) -(test "Get available diskspace" #t (number? (get-df "./"))) -(test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) - (or (equal? "./" bestdir) - (equal? "/tmp" bestdir)))) -(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n"))) - -;; db -(define row (vector "a" "b" "c" "blah")) -(define header (list "col1" "col2" "col3" "col4")) -(test "Get row by header" "blah" (db:get-value-by-header row header "col4")) - -;; (define *toppath* "tests") -(define *db* #f) -(test "open-db" #t (begin - (set! *db* (open-db)) - (if *db* #t #f))) - -;; quit wasting time, I'm changing *db* to db -(define db *db*) - -(test "get cpu load" #t (number? (get-cpu-load))) -(test "get uname" #t (string? (get-uname))) - -(test "get validvalues as list" (list "start" "end" "completed") - (string-split (config-lookup *configdat* "validvalues" "state"))) - -(for-each (lambda (item) - (test (conc "get valid items (" item ")") - item (items:check-valid-items "state" item))) - (list "start" "end" "completed")) - -(for-each (lambda (item) - (test (conc "get valid items (" item ")") - item (items:check-valid-items "status" item))) - (list "pass" "fail" "n/a")) - -(test #f #f (items:check-valid-items "state" "blahfool")) - -(test "write env files" "nada.csh" (begin - (save-environment-as-files "nada") - (and (file-exists? "nada.sh") - (file-exists? "nada.csh")))) - -(test #f #t (cdb:client-call *runremote* 'immediate #t 1 (lambda ()(display "Got here eh!?") #t))) - -;; (set! *verbosity* 20) -(test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*))) -(test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS")) -;; (set! *verbosity* 1) -;; (cdb:set-verbosity *runremote* *verbosity*) - -(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) - - -(test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) - -(define remargs (args:get-args - '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada") - (list ":runname" ":state" ":status") - (list "-h") - args:arg-hash - 0)) - -(test "register-run" #t (number? (runs:register-run *db* - (db:get-keys *db*) - '(("SYSTEM" "key1")("RELEASE" "key2")) - "myrun" - "new" - "n/a" - "bob"))) - -(test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) -(test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) -(test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) -(test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) - -(define keys (db:get-keys *db*)) - -;;====================================================================== -;; D B -;;====================================================================== - -(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) -(test #f (vector '("SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time") '()) - (runs:get-runs-by-patt db keys "%")) -(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) -(test #f #t (runs:operate-on 'print "%" "%" "%")) - -;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" -(setenv "BLAHFOO" "1234") -(unsetenv "NADAFOO") -(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) - (result (get-environment-variable "NADAFOO"))) - (alist->env-vars prevvals) - result)) - -(test "env restored" "1234" (get-environment-variable "BLAHFOO")) - - -(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))))) -(set! *verbosity* 6) -(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d")))) -(set! *verbosity* -1) -(test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) -(set! *verbosity* 1) -(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) -(test "Items table empty items I" '() (item-table->item-list '(("A")))) -(test "Items table empty items II" '() (item-table->item-list '(("A" "")))) - -;; Test out the steps code - -(define test-id #f) - -;; force keepgoing -; (hash-table-set! args:arg-hash "-keepgoing" #t) -(hash-table-set! args:arg-hash "-itempatt" "%") -(hash-table-set! args:arg-hash "-testpatt" "%") -(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") -(test "Setup for a run" #t (begin (setup-for-run) #t)) - -(define *tdb* #f) - -(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) -(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) - -(print "Using " testdbpath " for test db") -(test #f #t (let ((db (open-test-db testdbpath))) - (set! *tdb* db) - (sqlite3#database? db))) -(sqlite3#finalize! *tdb*) - -;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) -(define tconfig #f) -(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) - (set! tconfig tconf) - (hash-table? tconf))) -(db:clean-all-caches) -;; (set! *verbosity* 20) -(test "Run a test" #t (general-run-call - "-runtests" - "run a test" - (lambda (target runname keys keynames keyvallst) - (let ((test-patts "test%")) - ;; (runs:run-tests target runname test-patts user (make-hash-table)) - (run:test 1 ;; run-id - (args:get-arg ":runname") - (keys:target->keyval keys target) - (vector - "test1" ;; testname - tconfig ;; testconfig - '() ;; waitons - 0 ;; priority - #f ;; items - #f ;; itemsdat - #f ;; spare - ) - args:arg-hash ;; flags (e.g. -itemspatt) - #f))))) - -(test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) - (non-cached (db:get-test-info-not-cached-by-id db 2))) - (print "\nCached: " cached-info) - (print "Noncached: " non-cached) - (equal? cached-info non-cached))) - -(change-directory test-work-dir) -(test "Add a step" #t - (begin - (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") - (sleep 2) - (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") - (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '())))) - (number? test-id))) - -(test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) - (print "Rundir " rundir) - (system (conc "mkdir -p " rundir)) - (string? rundir))) -(test #f #t (sqlite3#database? (open-test-db "./"))) -(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" - (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id))) - (if tdb (sqlite3#finalize! tdb)) - (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) - -(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id))) - (print steps) - (> (length steps) 0))) -(test "Get nice table for steps" "2.0s" - (begin - (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) - -;; (exit) - -(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1)) - -(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS")) - -;;====================================================================== -;; R E M O T E C A L L S -;;====================================================================== - -(define start-wait (current-seconds)) -(print "Starting intensive cache and rpc test") -(for-each (lambda (params) - (print "Intensive: params=" params) - (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") - (apply cdb:test-set-status-state *runremote* test-id params) - (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) - (cdb:test-rollup-test_data-pass-fail *runremote* test-id) - (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params)) - (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level - '(("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("NOT_STARTED" "FAIL" "Just testing") - ("COMPLETED" "PASS" #f) - ("NOT_STARTED" "FAIL" "Just testing") - ("KILLED" "UNKNOWN" "More testing") - ("KILLED" "UNKNOWN" "More testing") - )) - -;; now set all tests to completed -(cdb:flush-queue *runremote*) -(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) - (print "Setting " (length tests) " to COMPLETED/PASS") - (for-each - (lambda (test) - (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) - tests)) - -;; (process-wait server-pid) -;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) -;; (print "Server ran for " run-delta " seconds") -;; (> run-delta 20))) - -(test "Rollup the run(s)" #t (begin - (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") - #t)) - -(hash-table-set! args:arg-hash ":runname" "%") - -(test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) - -(print "Waiting for server to be done, should be about 20 seconds") -(cdb:kill-server *runremote*) - -;; (thread-join! th1 th2 th3) - -;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) -;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '()) +(let* ((unit-test-name (list-ref (argv) 4)) + (fname (conc "../unittests/" unit-test-name ".scm"))) + (if (file-exists? fname) + (load fname) + (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) + + + (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") + (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") + (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") + (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) + ADDED tests/unittests/basicserver.scm Index: tests/unittests/basicserver.scm ================================================================== --- /dev/null +++ tests/unittests/basicserver.scm @@ -0,0 +1,220 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(delete-file* "logs/1.log") +(define run-id 1) + +(test "setup for run" #t (begin (launch:setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +;; NON Server tests go here + +(test #f #f (db:dbdat-get-path *db*)) +(test #f #f (db:get-run-name-from-id *db* run-id)) +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + +;; (exit) + +;; Server tests go here +(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) +(server:kind-run run-id) +(test "did server start within 20 seconds?" + #t + (let loop ((remtries 20) + (running (tasks:server-running-or-starting? (db:delay-if-busy + (tasks:open-db)) + run-id))) + (if running + (> running 0) + (if (> remtries 0) + (begin + (thread-sleep! 1.1) + (loop (- remtries 1) + (tasks:server-running-or-starting? (db:delay-if-busy + (tasks:open-db)) + run-id))))))) + +(test "did server become available" #t + (let loop ((remtries 10) + (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) + (if res + (vector? res) + (begin + (if (> remtries 0) + (begin + (thread-sleep! 1.1) + (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) + res))))) + +(define user (current-user-name)) +(define runname "mytestrun") +(define keys (rmt:get-keys)) +(define runinfo #f) +(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +(define header (vector "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) + +;; Setup +;; +(test #f #f (not (client:setup run-id))) +(test #f #f (not (hash-table-ref/default *runremote* run-id #f))) + +;; Login +;; +(test #f '(#t "successful login") (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id)) +(test #f '(#t "successful login") (rmt:login run-id)) + +;; Keys +;; +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + +;; No data in db +;; +(test #f '() (rmt:get-all-run-ids)) +(test #f #f (rmt:get-run-name-from-id run-id)) +(test #f + (let ((runrec (vector #f #f))) + (vector-set! runrec header 0) + (vector-set! runrec (vector #f #f #f #f) 1) + runrec) + (rmt:get-run-info run-id)) + +;; Insert data into db +;; +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +;; (test #f #f (rmt:get-runs-by-patt keys runname)) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) + +;; With data in db +;; +(test #f '(1) (rmt:get-all-run-ids)) +(test #f runname (rmt:get-run-name-from-id run-id)) +(test #f + runname + (let ((run-info (rmt:get-run-info run-id))) + (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) + "runname"))) + + ;; (vector header (vector "abc" "def" 1 "mytestrun" "new" "n/a" "matt" 1416280640.0)) + +;; test killing server +;; +(tasks:kill-server-run-id run-id) + +(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) + +;; (test #f #f (client:setup run-id)) + +;; (set! *transport-type* 'http) +;; +;; (test "setup for run" #t (begin (launch:setup-for-run) +;; (string? (getenv "MT_RUN_AREA_HOME")))) +;; +;; (test "server-register, get-best-server" #t (let ((res #f)) +;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) +;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) +;; (number? (vector-ref res 3)))) +;; +;; (test "de-register server" #f (let ((res #f)) +;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) +;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) +;; +;; (define server-pid #f) +;; +;; ;; Not sure how the following should work, replacing it with system of megatest -server +;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; ;; (daemon:ize) +;; ;; (server:launch 'http))))) +;; ;; (set! server-pid pid) +;; ;; (number? pid))) +;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; +;; (let loop ((n 10)) +;; (thread-sleep! 1) ;; need to wait for server to start. +;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) +;; (print "tasks:get-best-server returned " res) +;; (if (and (not res) +;; (> n 0)) +;; (loop (- n 1))))) +;; +;; (test "get-best-server" #t (begin +;; (client:launch) +;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) +;; (vector? dat)))) +;; +;; (define *keys* (keys:config-get-fields *configdat*)) +;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) +;; +;; (test #f #t (string? (car *runremote*))) +;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) +;; +;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test +;; +;; ;; RUNS +;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) +;; (vector-ref (vector-ref rinfo 1) 3))) +;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) +;; +;; ;; TESTS +;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) +;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +;; (test "get keys" #t (list? (rmt:get-keys))) +;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) +;; (db:test-get-comment trec))) +;; +;; ;; MORE RUNS +;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) +;; (header (vector-ref runs 0)) +;; (data (vector-ref runs 1))) +;; (and (list? header) +;; (list? data) +;; (vector? (car data))))) +;; +;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) +;; +;; ;;====================================================================== +;; ;; D B +;; ;;====================================================================== +;; +;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) +;; (+ (db:test-get-pass_count dat) +;; (db:test-get-fail_count dat)))) +;; +;; (define testregistry (make-hash-table)) +;; (for-each +;; (lambda (tname) +;; (for-each +;; (lambda (itempath) +;; (let ((tkey (conc tname "/" itempath)) +;; (rpass (random 10)) +;; (rfail (random 10))) +;; (hash-table-set! testregistry tkey (list tname itempath)) +;; (rmt:general-call 'register-test 1 tname itempath) +;; (let* ((tid (rmt:get-test-id 1 tname itempath)) +;; (tdat (rmt:get-test-info-by-id tid))) +;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) +;; (let* ((resdat (rmt:get-test-info-by-id tid))) +;; (test "set/get pass fail counts" (list rpass rfail) +;; (list (db:test-get-pass_count resdat) +;; (db:test-get-fail_count resdat))))))) +;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) +;; (list "test1" "test2" "test3" "test4" "test5")) +;; +;; +;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) +;; + +(exit) ADDED tests/unittests/configfiles.scm Index: tests/unittests/configfiles.scm ================================================================== --- /dev/null +++ tests/unittests/configfiles.scm @@ -0,0 +1,52 @@ +;;====================================================================== +;; C O N F I G F I L E S +;;====================================================================== + +(define conffile #f) +(test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) +(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) + +(set! conffile (read-config "test.config" #f #f)) +(test "Get available diskspace" #t (number? (get-df "./"))) +(test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) + (or (equal? "./" bestdir) + (equal? "/tmp" bestdir)))) +(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n"))) + +;; db +(define row (vector "a" "b" "c" "blah")) +(define header (list "col1" "col2" "col3" "col4")) +(test "Get row by header" "blah" (db:get-value-by-header row header "col4")) + +;; (define *toppath* "tests") +(define *db* #f) +(test "open-db" #t (begin + (set! *db* (open-db)) + (if *db* #t #f))) + +;; quit wasting time, I'm changing *db* to db +(define db *db*) + +(test "get cpu load" #t (number? (get-cpu-load))) +(test "get uname" #t (string? (get-uname))) + +(test "get validvalues as list" (list "start" "end" "completed") + (string-split (config-lookup *configdat* "validvalues" "state"))) + +(for-each (lambda (item) + (test (conc "get valid items (" item ")") + item (items:check-valid-items "state" item))) + (list "start" "end" "completed")) + +(for-each (lambda (item) + (test (conc "get valid items (" item ")") + item (items:check-valid-items "status" item))) + (list "pass" "fail" "n/a")) + +(test #f #f (items:check-valid-items "state" "blahfool")) + +(test "write env files" "nada.csh" (begin + (save-environment-as-files "nada") + (and (file-exists? "nada.sh") + (file-exists? "nada.csh")))) + ADDED tests/unittests/dbrdbstruct.scm Index: tests/unittests/dbrdbstruct.scm ================================================================== --- /dev/null +++ tests/unittests/dbrdbstruct.scm @@ -0,0 +1,33 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(test #f #t (vector? (make-dbr:dbstruct "/tmp"))) + +(define dbstruct (make-dbr:dbstruct "/tmp")) + +(test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t)) +(test #f "blah" (dbr:dbstruct-get-main dbstruct)) +(for-each + (lambda (run-id) + (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id)))) + (list 1 2 3 4 5 6 7 8 9 #f)) + +(test #f 0 (dbr:dbstruct-field-name->num 'rundb)) +(test #f 1 (dbr:dbstruct-field-name->num 'inmem)) +(test #f 2 (dbr:dbstruct-field-name->num 'mtime)) + +(test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) +(test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t)) +(test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) + +(for-each + (lambda (k) + (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t)) + (test #f (conc k) (dbr:dbstruct-get-runvec-val dbstruct 1 k))) + '(rundb inmem mtime rtime stime inuse)) + ADDED tests/unittests/inmemdb.scm Index: tests/unittests/inmemdb.scm ================================================================== --- /dev/null +++ tests/unittests/inmemdb.scm @@ -0,0 +1,44 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(system "cp ../fullrun/megatest.db megatest.db") + +(test "open inmem db" 1 (begin (open-in-mem-db) 1)) + +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +(system "megatest -server - -debug 0 &") + +(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(define inmem (db:open-inmem-db)) + +(define (inmem-test t b) + (test "inmem sync to" t (db:sync-to *db* inmem)) + (test "inmem sync back" b (db:sync-to inmem *db*))) + +(inmem-test 0 0) + +(inmem-test 1 1) + +;;====================================================================== +;; D B +;;====================================================================== + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + + ADDED tests/unittests/misc.scm Index: tests/unittests/misc.scm ================================================================== --- /dev/null +++ tests/unittests/misc.scm @@ -0,0 +1,45 @@ +;;====================================================================== +;; P R O C E S S E S +;;====================================================================== + +(test "cmd-run-with-stderr->list" '("No such file or directory") + (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist"))) + (string-search (regexp "No such file or directory")(car reslst)))) + +;;====================================================================== +;; T E S T M A T C H I N G +;;====================================================================== + +;; tests:glob-like-match +(test #f '("abc") (tests:glob-like-match "abc" "abc")) +(for-each + (lambda (patt str expected) + (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str))) + (list "abc" "~abc" "~abc" "a*c" "a%c") + (list "abc" "abcd" "abc" "ABC" "ABC") + (list '("abc") #t #f #f '("ABC")) + ) + +;; tests:match +(test #f #t (tests:match "abc/def" "abc" "def")) +(for-each + (lambda (patterns testname itempath expected) + (test (conc patterns " " testname "/" itempath "=>" expected) + expected + (tests:match patterns testname itempath))) + (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/") + (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a") + (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b") + (list #t #t #t #f #f #t #t #t #f #t #t #t #f)) + +;; db:patt->like +(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND ")) +(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND ")) +(test #f "item_path GLOB ''" (db:patt->like "item_path" "")) + +;; test:match->sqlqry +(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" + (tests:match->sqlqry "a/b,a%,/b%")) +(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" + (tests:match->sqlqry "a/b,a%,%/b%")) + ADDED tests/unittests/runs.scm Index: tests/unittests/runs.scm ================================================================== --- /dev/null +++ tests/unittests/runs.scm @@ -0,0 +1,275 @@ +(define keys (db:get-keys *db*)) + +(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) + +(test "register-run" #t (number? + (db:register-run *db* + '(("SYSTEM" "key1")("RELEASE" "key2")) + "myrun" + "new" + "n/a" + "bob"))) + +(test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) +(test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) +(test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) +(test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) + +(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) +(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) + +(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) +(test #f #t (runs:operate-on 'print "%" "%" "%")) + +;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" +(setenv "BLAHFOO" "1234") +(unsetenv "NADAFOO") +(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) + (result (get-environment-variable "NADAFOO"))) + (alist->env-vars prevvals) + result)) + +(test "env restored" "1234" (get-environment-variable "BLAHFOO")) + + +(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))))) +(set! *verbosity* 6) +(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d")))) +(set! *verbosity* -1) +(test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) +(set! *verbosity* 1) +(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) +(test "Items table empty items I" '() (item-table->item-list '(("A")))) +(test "Items table empty items II" '() (item-table->item-list '(("A" "")))) + +;; Test out the steps code + +(define test-id #f) + +;; force keepgoing +; (hash-table-set! args:arg-hash "-keepgoing" #t) +(hash-table-set! args:arg-hash "-itempatt" "%") +(hash-table-set! args:arg-hash "-testpatt" "%") +(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") +(test "Setup for a run" #t (begin (setup-for-run) #t)) + +(define *tdb* #f) +(define keyvals #f) +(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) + (set! keyvals kv)(list? keyvals))) + +(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) +(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) + +(print "Using " testdbpath " for test db") +(test #f #t (let ((db (open-test-db testdbpath))) + (set! *tdb* db) + (sqlite3#database? db))) +(sqlite3#finalize! *tdb*) + +;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) +(define tconfig #f) +(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) + (set! tconfig tconf) + (hash-table? tconf))) +(db:clean-all-caches) + +(test "set-megatest-env-vars" + "ubuntu" + (begin + (set-megatest-env-vars 1 inkeys: keys) + (get-environment-variable "SYSTEM"))) +(test "setup-env-defaults" + "see this variable" + (begin + (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (get-environment-variable "ALLTESTS"))) + +(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash))) + +(define rinfo #f) +(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1))) + (set! rinfo rinf) + rinf) 0))) +(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1))) +(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table))) + +(test "update-test_meta" "test1" (begin + (runs:update-test_meta "test1" tconfig) + (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1"))) + (vector-ref dat 1)))) + +(define test-path "tests/test1") +(define disk-path #f) +(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*))) + (set! disk-path d) + d)))) +(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '())))) +(test #f "" (item-list->path '())) + +(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) + + +(test "Run a test" #t (general-run-call + "-runtests" + "run a test" + (lambda (target runname keys keyvallst) + (let ((test-patts "test%")) + ;; (runs:run-tests target runname test-patts user (make-hash-table)) + ;; (run:test run-id run-info key-vals runname test-record flags parent-test) + ;; (set! *verbosity* 22) ;; (list 0 1 2)) + (run:test 1 ;; run-id + #f ;; run-info is yet only a dream + keyvallst ;; (keys:target->keyval keys target) + "run1" ;; runname + (vector ;; test_records.scm tests:testqueue + "test1" ;; testname + tconfig ;; testconfig + '() ;; waitons + 0 ;; priority + #f ;; items + #f ;; itemsdat + "" ;; itempath + ) + args:arg-hash ;; flags (e.g. -itemspatt) + #f) + ;; (set! *verbosity* 0) + )))) + + + + + +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) + +(exit 1) +;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) +;; (non-cached (db:get-test-info-not-cached-by-id db 2))) +;; (print "\nCached: " cached-info) +;; (print "Noncached: " non-cached) +;; (equal? cached-info non-cached))) + +(change-directory test-work-dir) +(test "Add a step" #t + (begin + (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") + (sleep 2) + (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") + (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '())))) + (number? test-id))) + +(test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) + (print "Rundir " rundir) + (system (conc "mkdir -p " rundir)) + (string? rundir))) +(test #f #t (sqlite3#database? (open-test-db "./"))) +(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" + (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id))) + (if tdb (sqlite3#finalize! tdb)) + (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) + +(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id))) + (print steps) + (> (length steps) 0))) +(test "Get nice table for steps" "2.0s" + (begin + (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) + +;; (exit) + +(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1)) + +(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS")) + +;;====================================================================== +;; R E M O T E C A L L S +;;====================================================================== + +(define start-wait (current-seconds)) +(print "Starting intensive cache and rpc test") +(for-each (lambda (params) + (print "Intensive: params=" params) + (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") + (apply cdb:test-set-status-state *runremote* test-id params) + (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) + (cdb:test-rollup-test_data-pass-fail *runremote* test-id) + (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params)) + (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level + '(("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("KILLED" "UNKNOWN" "More testing") + )) + +;; now set all tests to completed +(cdb:flush-queue *runremote*) +(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) + (print "Setting " (length tests) " to COMPLETED/PASS") + (for-each + (lambda (test) + (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) + tests)) + +;; (process-wait server-pid) +;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) +;; (print "Server ran for " run-delta " seconds") +;; (> run-delta 20))) + +(test "Rollup the run(s)" #t (begin + (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") + #t)) + +(hash-table-set! args:arg-hash ":runname" "%") + +(test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) + +(print "Waiting for server to be done, should be about 20 seconds") +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) + +;; (cdb:kill-server *runremote*) + +;; (thread-join! th1 th2 th3) + +;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) +;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '()) ADDED tests/unittests/server.scm Index: tests/unittests/server.scm ================================================================== --- /dev/null +++ tests/unittests/server.scm @@ -0,0 +1,116 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +(test "server-register, get-best-server" #t (let ((res #f)) + (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) + (set! res (open-run-close tasks:get-best-server tasks:open-db)) + (number? (vector-ref res 3)))) + +(test "de-register server" #f (let ((res #f)) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) + +(define server-pid #f) + +;; Not sure how the following should work, replacing it with system of megatest -server +;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; (daemon:ize) +;; (server:launch 'http))))) +;; (set! server-pid pid) +;; (number? pid))) +(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") + +(let loop ((n 10)) + (thread-sleep! 1) ;; need to wait for server to start. + (let ((res (open-run-close tasks:get-best-server tasks:open-db))) + (print "tasks:get-best-server returned " res) + (if (and (not res) + (> n 0)) + (loop (- n 1))))) + +(test "get-best-server" #t (begin + (client:launch) + (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) + (vector? dat)))) + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test + +;; RUNS +(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) + (vector-ref (vector-ref rinfo 1) 3))) +(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) + +;; TESTS +(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +(test "register test" #t (rmt:general-call 'register-test 1 1 "test1" "")) +(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) + +(test "sync back" #t (> (rmt:sync-inmem->db) 0)) +(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) + +(test "get keys" #t (list? (rmt:get-keys))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1))) + (db:test-get-comment trec))) + +;; MORE RUNS +(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) + (header (vector-ref runs 0)) + (data (vector-ref runs 1))) + (and (list? header) + (list? data) + (vector? (car data))))) + +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) + +;;====================================================================== +;; D B +;;====================================================================== + +(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) + (+ (db:test-get-pass_count dat) + (db:test-get-fail_count dat)))) + +(define testregistry (make-hash-table)) +(for-each + (lambda (tname) + (for-each + (lambda (itempath) + (let ((tkey (conc tname "/" itempath)) + (rpass (random 10)) + (rfail (random 10))) + (hash-table-set! testregistry tkey (list tname itempath)) + (rmt:general-call 'register-test 1 tname itempath) + (let* ((tid (rmt:get-test-id 1 tname itempath)) + (tdat (rmt:get-test-info-by-id tid))) + (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) + (let* ((resdat (rmt:get-test-info-by-id tid))) + (test "set/get pass fail counts" (list rpass rfail) + (list (db:test-get-pass_count resdat) + (db:test-get-fail_count resdat))))))) + (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) + (list "test1" "test2" "test3" "test4" "test5")) + + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + ADDED tests/unittests/tests.scm Index: tests/unittests/tests.scm ================================================================== --- /dev/null +++ tests/unittests/tests.scm ADDED tests/watch-monitor.sh Index: tests/watch-monitor.sh ================================================================== --- /dev/null +++ tests/watch-monitor.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +if [ -e fullrun/db/monitor.db ];then +sqlite3 fullrun/db/monitor.db << EOF +.header on +.mode column +select * from servers order by start_time desc; +.q +EOF +fi ADDED tree.scm Index: tree.scm ================================================================== --- /dev/null +++ tree.scm @@ -0,0 +1,142 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tree)) +(declare (uses margs)) +(declare (uses launch)) +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses db)) +(declare (uses server)) +(declare (uses synchash)) +(declare (uses dcommon)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") + +;;====================================================================== +;; T R E E S T U F F +;;====================================================================== + +;; path is a list of nodes, each the child of the previous +;; this routine returns the id so another node can be added +;; either as a leaf or as a branch +;; +;; BUG: This needs a stop sensor for when a branch is exhausted +;; +(define (tree:find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree:add-node obj top nodelst #!key (userdata #f)) + (if (or (not (string? (iup:attribute obj "TITLE0"))) + (string-null? (iup:attribute obj "TITLE0"))) + (iup:attribute-set! obj "ADDBRANCH0" top)) + (cond + ((not (equal? top (iup:attribute obj "TITLE0"))) + (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree:find-node obj pathl)) + (nodenum (tree:find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) + +(define (tree:node->path obj nodenum) + (let loop ((currnode 0) + (path '())) + (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) + (node-title (iup:attribute obj (conc "TITLE" currnode))) + (trimpath (if (and (not (null? path)) + (> (length path) node-depth)) + (take path node-depth) + path)) + (newpath (append trimpath (list node-title)))) + (if (>= currnode nodenum) + newpath + (loop (+ currnode 1) + newpath))))) + +(define (tree:delete-node obj top node-path) ;; node-path is a list of strings + (let ((id (tree:find-node obj (cons top node-path)))) + (print "Found node to remove " id " for path " top " " node-path) + (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) + +#| + + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-set-curr-run-id! *data* run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) +|# ADDED txtdb/metadat.scm Index: txtdb/metadat.scm ================================================================== --- /dev/null +++ txtdb/metadat.scm @@ -0,0 +1,553 @@ +(define minimal-sxml + '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") + (http://www.gnumeric.org/v10.dtd:Workbook + (@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-26T05:41:51Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-26T05:41:10Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Sheet1")) + (http://www.gnumeric.org/v10.dtd:Geometry + (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:Sheets + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "Sheet1") + (http://www.gnumeric.org/v10.dtd:MaxCol "-1") + (http://www.gnumeric.org/v10.dtd:MaxRow "-1") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Sheet1\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "0") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols (@ (DefaultSizePts "48"))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75"))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:Cells) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0"))))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))))) + +(define sheet-meta + '(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "8") + (http://www.gnumeric.org/v10.dtd:MaxRow "18") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "hh\":\"mm\":\"ss AM/PM") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") (startCol "0") (endRow "65535") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "0") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "31") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "8") (endRow "255") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "2") (Count "7")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.64") (No "0"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (Count "17"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.1") (No "18")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "3") (CursorCol "1")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "3") (startCol "1") (endRow "3") (endCol "1")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout + (@ (TopLeft "A2")) + (http://www.gnumeric.org/v10.dtd:FreezePanes + (@ (UnfrozenTopLeft "A2") (FrozenTopLeft "A1")))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0"))))) + +(define sheets-meta + '((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-26T04:47:02Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-26T04:46:14Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "First_Sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Second-sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "RunsToDo") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "RunsToLock")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "1"))))) + +(define workbook-meta + '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\""))) + ADDED txtdb/nada3/First_Sheet.dat Index: txtdb/nada3/First_Sheet.dat ================================================================== --- /dev/null +++ txtdb/nada3/First_Sheet.dat @@ -0,0 +1,153 @@ +[Time] +BLANKVAL +A 0.324305555555556 +B 0.33125 +C 0.334722222222222 +D 0.336805555555556 +E 0.338888888888889 +F 0.340972222222222 +G 0.343055555555556 +H 0.345833333333333 +I 0.347916666666667 +J 0.351388888888889 +K 0.366666666666667 +L 0.379166666666667 +M 0.395833333333333 +N 0.422222222222222 +O 0.452083333333333 +P 0.491666666666667 +Q 0.570833333333333 + +[DeltaTime] +A 0 +B =days(B3,$B$2)*24*60 +C +D +E +F +G +H +I +J +K +L +M +N +O +P +Q + +[Ambient] +A 35.4 +B 35.4 +C 35 +D 35 +E 35 +F 35 +G 35 +H 36 +I 36 +J 37 +K 37 +L 38 +M 39 +N 40 +O 41 +P 41 +Q 41.5 + +[Firebox] +A 34.3 +B 72 +C 100 +D 130 +E 145 +F 150 +G 150 +H 158 +I 156 +J 152 +K 134 +L 117 +M 100 +N 91 +O 79 +P 68 +Q 51 + +[2nd_row] +A 34.3 +B 60 +C 90 +D 116 +E 121 +F 125 +G 128 +H 129 +I 128 +J 126 +K 117 +L 108 +M 100 +N 90 +O 78 +P 63 +Q 51 + +[3rd_row] +A 34.1 +B 42 +C 57 +D 69 +E 73 +F 78 +G 82 +H 86 +I 87 +J 89 +K 94 +L 96 +M 93 +N 88 +O 77 +P 64 +Q 51 + +[4th_row] +A 34 +B 39 +C 46 +D 52 +E 54 +F 56 +G 60 +H 62 +I 65 +J 67 +K 77 +L 82 +M 82 +N 81 +O 72 +P 62 +Q 51 + +[Exit] +A 34 +B 68 +C 68 +D 68 +E 68 +F 68 +G 69 +H 70 +I 72 +J 75 +K 107 +L 106 +M 106 +N 100 +O 79 +P 68 +Q 51 + ADDED txtdb/nada3/RunsToDo.dat Index: txtdb/nada3/RunsToDo.dat ================================================================== --- /dev/null +++ txtdb/nada3/RunsToDo.dat @@ -0,0 +1,15 @@ +[a/b/c] +123 a +456 b +789 c + +[d/e/f] +123 e +456 f +789 g + +[g/h/i] +123 h +456 i +789 j + ADDED txtdb/nada3/RunsToLock.dat Index: txtdb/nada3/RunsToLock.dat ================================================================== --- /dev/null +++ txtdb/nada3/RunsToLock.dat @@ -0,0 +1,11 @@ +[def] +ghi jkl +qrst +uvwx +yz12 + +[mno] +abc +def xyz +jkl +mnop ADDED txtdb/nada3/Second-sheet.dat Index: txtdb/nada3/Second-sheet.dat ================================================================== --- /dev/null +++ txtdb/nada3/Second-sheet.dat @@ -0,0 +1,34 @@ +[2] +V2 X +V6 Y +V8 Z +V12 E +V15 B +V17 + + +[A1] +V8 Z +V17 = + +# Just a test really +# +V1 X +V3 X +V5 Y +V7 Y +V10 Z +V11 E +V13 E +V14 B +V16 B +[3] +V2 John, +V6 Tom +V8 Fred +V17 ~ + +# a deeply held belief is a danger to sanity +# +V4 X +row-11 Z +row-18 B ADDED txtdb/nada3/Sheet3.dat Index: txtdb/nada3/Sheet3.dat ================================================================== --- /dev/null +++ txtdb/nada3/Sheet3.dat @@ -0,0 +1,8 @@ +[zeroth title] +row1name +row2name + +[col1title] +row1name row1value +row2nameNoValue +row3name row3value ADDED txtdb/nada3/sheet-names.cfg Index: txtdb/nada3/sheet-names.cfg ================================================================== --- /dev/null +++ txtdb/nada3/sheet-names.cfg @@ -0,0 +1,4 @@ +First_Sheet +Second-sheet +RunsToDo +RunsToLock ADDED txtdb/nada3/sxml/First_Sheet.sxml Index: txtdb/nada3/sxml/First_Sheet.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/First_Sheet.sxml @@ -0,0 +1,460 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "8") + (http://www.gnumeric.org/v10.dtd:MaxRow "19") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "Pt") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "4096") (startCol "0") (endRow "65535") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "4") (endRow "255") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "0") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "31") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "hh\":\"mm\":\"ss AM/PM") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "16") (endRow "4095") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") (startCol "0") (endRow "4095") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "1") (MarginB "2") (MarginA "2") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "2") (MarginB "2") (MarginA "2") (Count "7")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.64") (No "0") (MarginB "0") (MarginA "0"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (MarginB "0") (MarginA "0") (Count "17"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.1") (No "18") (MarginB "0") (MarginA "0") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "3") (CursorCol "1")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "3") (startCol "1") (endRow "3") (endCol "1")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout + (@ (TopLeft "A2")) + (http://www.gnumeric.org/v10.dtd:FreezePanes + (@ (UnfrozenTopLeft "A2") (FrozenTopLeft "A1")))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "0") + (PerformR "0") + (NonNeg "1") + (MaxTime "60") + (MaxIter "1000") + (LimitsR "0") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/RunsToDo.sxml Index: txtdb/nada3/sxml/RunsToDo.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/RunsToDo.sxml @@ -0,0 +1,109 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "4") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"RunsToDo\"") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "Pt") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2") (Count "4")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (MarginB "0") (MarginA "0") (Count "4"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.75") (No "4") (MarginB "0") (MarginA "0")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "3") (CursorCol "2")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "3") (startCol "2") (endRow "3") (endCol "2")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "0") + (PerformR "0") + (NonNeg "1") + (MaxTime "60") + (MaxIter "1000") + (LimitsR "0") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/RunsToLock.sxml Index: txtdb/nada3/sxml/RunsToLock.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/RunsToLock.sxml @@ -0,0 +1,92 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "1") + (http://www.gnumeric.org/v10.dtd:MaxRow "1") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "cm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "cm") (Points "120")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left "")))) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.75") (No "0") (MarginB "0") (MarginA "0") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "1") + (PerformR "0") + (NonNeg "1") + (MaxTime "0") + (MaxIter "0") + (LimitsR "0") + (Inputs "") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/Second-sheet.sxml Index: txtdb/nada3/sxml/Second-sheet.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/Second-sheet.sxml @@ -0,0 +1,428 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "21") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Second-sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "Pt") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "4096") (startCol "0") (endRow "65535") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "4") (endRow "255") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "17") (startCol "3") (endRow "31") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "16") (startCol "3") (endRow "16") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "1") + (Rotation "0") + (PatternColor "FFFF:FFFF:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:CCCC:0")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "16") (endRow "4095") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "3") (endRow "15") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "0") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "28") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") (startCol "0") (endRow "4095") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "0") (MarginB "2") (MarginA "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "1") (MarginB "2") (MarginA "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "2") (MarginB "2") (MarginA "2") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "227.2") (No "3") (MarginB "2") (MarginA "2") (HardSize "1")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "60") (No "0") (MarginB "0") (MarginA "0") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (MarginB "0") (MarginA "0") (Count "17"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.1") (No "18") (MarginB "0") (MarginA "0") (Count "4")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "3")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "3") (endRow "0") (endCol "3")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "0") + (PerformR "0") + (NonNeg "1") + (MaxTime "60") + (MaxIter "1000") + (LimitsR "0") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/Sheet3.sxml Index: txtdb/nada3/sxml/Sheet3.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/Sheet3.sxml @@ -0,0 +1,100 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "0") + (http://www.gnumeric.org/v10.dtd:MaxRow "0") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Sheet3\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "64.01") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.82") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) ADDED txtdb/nada3/sxml/_sheets.sxml Index: txtdb/nada3/sxml/_sheets.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/_sheets.sxml @@ -0,0 +1,46 @@ +((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v8.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "3") (Major "6") (Full "1.6.3") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (http://www.gnumeric.org/v10.dtd:Summary + (http://www.gnumeric.org/v10.dtd:Item + (http://www.gnumeric.org/v10.dtd:name "application") + (http://www.gnumeric.org/v10.dtd:val-string "gnumeric")) + (http://www.gnumeric.org/v10.dtd:Item + (http://www.gnumeric.org/v10.dtd:name "author") + (http://www.gnumeric.org/v10.dtd:val-string "matthew.r.welland"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName "First_Sheet") + (http://www.gnumeric.org/v10.dtd:SheetName "Second-sheet") + (http://www.gnumeric.org/v10.dtd:SheetName "RunsToDo") + (http://www.gnumeric.org/v10.dtd:SheetName "RunsToLock")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "3"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (EnableIteration "1")))) ADDED txtdb/nada3/sxml/_workbook.sxml Index: txtdb/nada3/sxml/_workbook.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/_workbook.sxml @@ -0,0 +1,1 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) ADDED txtdb/testdata.sxml Index: txtdb/testdata.sxml ================================================================== --- /dev/null +++ txtdb/testdata.sxml @@ -0,0 +1,1273 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") + (http://www.gnumeric.org/v10.dtd:Workbook + (@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-14T22:32:27Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-13T04:38:00Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "First_Sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Second-sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Sheet3")) + (http://www.gnumeric.org/v10.dtd:Geometry + (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:Sheets + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "First_Sheet") + (http://www.gnumeric.org/v10.dtd:MaxCol "8") + (http://www.gnumeric.org/v10.dtd:MaxRow "17") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "hh\":\"mm\":\"ss AM/PM") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") + (startCol "0") + (endRow "65535") + (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "0") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "31") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "8") (endRow "255") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "64") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "2") (Count "7")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.64") (No "0"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (Count "17")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "29") (CursorCol "1")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "29") + (startCol "1") + (endRow "29") + (endCol "1")))) + (http://www.gnumeric.org/v10.dtd:Cells + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "1")) + "Time") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "2")) + "DeltaTime") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "3")) + "Ambient") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "4")) + "Firebox") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "5")) + "2nd row") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "6")) + "3rd row") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "7")) + "4th row") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "8")) + "Exit ") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "1") (Col "0")) + "A") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "1")) + "0.32430555555555557") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "2")) + "0") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "3")) + "35.399999999999999") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "4")) + "34.299999999999997") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "5")) + "34.299999999999997") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "6")) + "34.100000000000001") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "7")) + "34") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "8")) + "34") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "2") (Col "0")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "1")) + "0.33124999999999999") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "2") (ExprID "1") (Col "2")) + "=days(B3,$B$2)*24*60") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "3")) + "35.399999999999999") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "4")) + "72") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "5")) + "60") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "6")) + "42") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "7")) + "39") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "3") (Col "0")) + "C") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "1")) + "0.3347222222222222") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "3") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "4")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "5")) + "90") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "6")) + "57") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "7")) + "46") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "4") (Col "0")) + "D") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "1")) + "0.33680555555555558") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "4") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "4")) + "130") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "5")) + "116") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "6")) + "69") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "7")) + "52") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "5") (Col "0")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "1")) + "0.33888888888888891") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "5") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "4")) + "145") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "5")) + "121") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "6")) + "73") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "7")) + "54") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "6") (Col "0")) + "F") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "1")) + "0.34097222222222223") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "6") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "4")) + "150") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "5")) + "125") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "6")) + "78") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "7")) + "56") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "7") (Col "0")) + "G") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "1")) + "0.34305555555555556") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "7") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "4")) + "150") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "5")) + "128") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "6")) + "82") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "7")) + "60") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "8")) + "69") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "8") (Col "0")) + "H") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "1")) + "0.34583333333333333") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "8") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "3")) + "36") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "4")) + "158") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "5")) + "129") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "6")) + "86") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "7")) + "62") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "8")) + "70") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "9") (Col "0")) + "I") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "1")) + "0.34791666666666665") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "9") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "3")) + "36") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "4")) + "156") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "5")) + "128") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "6")) + "87") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "7")) + "65") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "8")) + "72") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "10") (Col "0")) + "J") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "1")) + "0.35138888888888886") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "10") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "3")) + "37") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "4")) + "152") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "5")) + "126") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "6")) + "89") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "7")) + "67") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "8")) + "75") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "11") (Col "0")) + "K") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "1")) + "0.36666666666666664") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "11") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "3")) + "37") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "4")) + "134") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "5")) + "117") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "6")) + "94") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "7")) + "77") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "8")) + "107") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "12") (Col "0")) + "L") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "1")) + "0.37916666666666665") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "12") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "3")) + "38") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "4")) + "117") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "5")) + "108") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "6")) + "96") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "7")) + "82") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "8")) + "106") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "13") (Col "0")) + "M") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "1")) + "0.39583333333333331") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "13") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "3")) + "39") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "4")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "5")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "6")) + "93") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "7")) + "82") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "8")) + "106") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "14") (Col "0")) + "N") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "1")) + "0.42222222222222222") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "14") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "3")) + "40") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "4")) + "91") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "5")) + "90") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "6")) + "88") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "7")) + "81") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "8")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "15") (Col "0")) + "O") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "1")) + "0.45208333333333334") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "15") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "3")) + "41") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "4")) + "79") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "5")) + "78") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "6")) + "77") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "7")) + "72") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "8")) + "79") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "16") (Col "0")) + "P") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "1")) + "0.49166666666666664") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "16") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "3")) + "41") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "4")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "5")) + "63") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "6")) + "64") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "7")) + "62") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "17") (Col "0")) + "Q") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "1")) + "0.5708333333333333") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "17") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "3")) + "41.5") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "4")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "5")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "6")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "7")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "8")) + "51")) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "Second-sheet") + (http://www.gnumeric.org/v10.dtd:MaxCol "4") + (http://www.gnumeric.org/v10.dtd:MaxRow "20") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Second-sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "0") + (endRow "65279") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "65280") + (startCol "0") + (endRow "65534") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "65535") + (startCol "0") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "1") (Count "4")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (Count "20")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "4") (CursorCol "4")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "4") (startCol "4") (endRow "4") (endCol "4")))) + (http://www.gnumeric.org/v10.dtd:Cells + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "1")) + "A1") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "0") (Col "2")) + "2") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "3")) + "A1") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "0") (Col "4")) + "3") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "1") (Col "0")) + "V1") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "1") (Col "1")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "2") (Col "0")) + "V2") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "2") (Col "2")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "3") (Col "0")) + "V3") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "3") (Col "3")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "4") (Col "0")) + "V4") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "4") (Col "4")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "5") (Col "0")) + "V5") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "5") (Col "3")) + "Y") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "6") (Col "0")) + "V6") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "6") (Col "2")) + "Y") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "7") (Col "0")) + "V7") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "7") (Col "1")) + "Y") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "8") (Col "0")) + "V8") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "8") (Col "1")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "9") (Col "0")) + "V8") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "9") (Col "2")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "10") (Col "0")) + "V10") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "10") (Col "3")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "11") (Col "4")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "12") (Col "0")) + "V11") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "12") (Col "3")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "13") (Col "0")) + "V12") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "13") (Col "2")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "14") (Col "0")) + "V13") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "14") (Col "1")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "15") (Col "0")) + "V14") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "15") (Col "1")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "16") (Col "0")) + "V15") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "16") (Col "2")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "17") (Col "0")) + "V16") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "17") (Col "3")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "18") (Col "4")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "0")) + "V17") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "1")) + "-") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "2")) + "+") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "3")) + "=") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "4")) + "~")) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "Sheet3") + (http://www.gnumeric.org/v10.dtd:MaxCol "0") + (http://www.gnumeric.org/v10.dtd:MaxRow "0") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Sheet3\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "0") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.82") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:Cells) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0"))))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0"))))) Index: txtdb/txtdb.scm ================================================================== --- txtdb/txtdb.scm +++ txtdb/txtdb.scm @@ -1,19 +1,635 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use ssax) +(use sxml-serializer) +(use sxml-modifications) +(use regex) +(use srfi-69) +(use regex-case) +(use posix) +(use json) +(use csv) +(use srfi-18) + +(include "../megatest-fossil-hash.scm") ;; Read a non-compressed gnumeric file -(define (txtdb:read-gnumeric-xml fname) +(define (refdb:read-gnumeric-xml fname) (with-input-from-file fname (lambda () (ssax:xml->sxml (current-input-port) '())))) + +(define (find-section dat section #!key (depth 0)) + (let loop ((hed (car dat)) + (tal (cdr dat))) + (if (list? hed) + (let ((res (find-section hed section depth: (+ depth 1)))) + (if res + res + (if (null? tal) + #f + (loop (car tal)(cdr tal))))) + (if (eq? hed section) + tal + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + +(define (remove-section dat section) + (if (null? dat) + '() + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '())) + (let ((newres (if (and (list? hed) + (not (null? hed)) + (equal? (car hed) section)) + res + (cons hed res)))) + (if (null? tal) + (reverse newres) + (loop (car tal)(cdr tal) newres)))))) + +(define (list-sections dat) + (filter (lambda (x)(and x)) + (map (lambda (section) + (if (and (list? section) + (not (null? section))) + (car section) + #f)) + dat))) + +(define (string->safe-filename str) + (string-substitute (regexp " ") "_" str #t)) + +(define (sheet->refdb dat targdir) + (let* ((comment-rx (regexp "^#CMNT\\d+\\s*")) + (blank-rx (regexp "^#BLNK\\d+\\s*")) + (sheet-name (car (find-section dat 'http://www.gnumeric.org/v10.dtd:Name))) + ;; (safe-name (string->safe-filename sheet-name)) + (cells (find-section dat 'http://www.gnumeric.org/v10.dtd:Cells)) + (remaining (remove-section (remove-section dat 'http://www.gnumeric.org/v10.dtd:Name) + 'http://www.gnumeric.org/v10.dtd:Cells)) + (rownums (make-hash-table)) ;; num -> name + (colnums (make-hash-table)) ;; num -> name + (cols (make-hash-table)) ;; name -> ( (name val) ... ) + (col0title "")) + (for-each (lambda (cell) + (let ((rownum (string->number (car (find-section cell 'Row)))) + (colnum (string->number (car (find-section cell 'Col)))) + (valtype (let ((res (find-section cell 'ValueType))) + (if res (car res) #f))) + (value (let ((res (cdr (filter (lambda (x)(not (list? x))) cell)))) + (if (null? res) "" (car res))))) + ;; If colnum is 0 Then this is a row name, if rownum is 0 then this is a col name + (cond + ((and (not (eq? 0 rownum)) + (eq? 0 colnum)) ;; a blank in column zero is handled with the special name "row-N" + (hash-table-set! rownums rownum (if (equal? value "") + (conc "row-" rownum) + value))) + ((and (not (eq? 0 colnum)) + (eq? 0 rownum)) + (hash-table-set! colnums colnum (if (equal? value "") + (conc "col-" colnum) + value))) + ((and (eq? 0 rownum) + (eq? 0 colnum)) + (set! col0title value)) + (else + (let ((colname (hash-table-ref/default colnums colnum (conc "col-" colnum))) + (rowname (hash-table-ref/default rownums rownum (conc "row-" rownum)))) + (hash-table-set! cols colname (cons (list rowname value) + (hash-table-ref/default cols colname '())))))))) + cells) + (let ((ref-colnums (map (lambda (c) + (list (cdr c)(car c))) + (hash-table->alist colnums)))) + (with-output-to-file (conc targdir "/" sheet-name ".dat") + (lambda () + (if (not (string-null? col0title))(print "[" col0title "]")) + (for-each (lambda (colname) + (print "[" colname "]") + (for-each (lambda (row) + (let ((key (car row)) + (val (cadr row))) + (if (string-search comment-rx key) + (print val) + (if (string-search blank-rx key) + (print) + (if (string-search " " key) + (print "\"" key "\" " val) + (print key " " val)))))) + (reverse (hash-table-ref cols colname))) + ;; (print) + ) + (sort (hash-table-keys cols)(lambda (a b) + (let ((colnum-a (assoc a ref-colnums)) + (colnum-b (assoc b ref-colnums))) + (if (and colnum-a colnum-b) + (< (cadr colnum-a)(cadr colnum-b)) + (if (and (string? a) + (string? b)) + (string< a b)))))))))) + (with-output-to-file (conc targdir "/sxml/" sheet-name ".sxml") + (lambda () + (pp remaining))) + sheet-name)) + +(define (sxml->file dat fname) + (with-output-to-file fname + (lambda () + ;; (print (sxml-serializer#serialize-sxml dat)) + (pp dat)))) + +(define (file->sxml fname) + (let ((res (read-file fname read))) + (if (null? res) + (begin + (print "ERROR: file " fname " is malformed for read") + #f) + (car res)))) + +(define (replace-sheet-name-index indat sheets) + (let* ((rem-dat (remove-section indat 'http://www.gnumeric.org/v10.dtd:SheetNameIndex)) + (one-sht (find-section rem-dat 'http://www.gnumeric.org/v10.dtd:SheetName)) ;; for the future if I ever decide to do this "right" + (mk-entry (lambda (sheet-name) + (append '(http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256"))) + (list sheet-name)))) + (new-indx-values (map mk-entry sheets))) + (append rem-dat (list (cons 'http://www.gnumeric.org/v10.dtd:SheetNameIndex + new-indx-values))))) + + +;; Write an sxml gnumeric workbook to a refdb directory structure. +;; +(define (extract-refdb dat targdir) + (create-directory (conc targdir "/sxml") #t) + (let* ((wrkbk (find-section dat 'http://www.gnumeric.org/v10.dtd:Workbook)) + (wrk-rem (remove-section dat 'http://www.gnumeric.org/v10.dtd:Workbook)) + (sheets (find-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets)) + (sht-rem (remove-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets)) + (sheet-names (map (lambda (sheet) + (sheet->refdb sheet targdir)) + sheets))) + (sxml->file wrk-rem (conc targdir "/sxml/_workbook.sxml")) + (sxml->file sht-rem (conc targdir "/sxml/_sheets.sxml")) + (with-output-to-file (conc targdir "/sheet-names.cfg") + (lambda () + (map print sheet-names))))) + +(define (read-gnumeric-file fname) + (if (not (string-match (regexp ".*.gnumeric$") fname)) + (begin + (print "ERROR: Attempt to import gnumeric file with extention other than .gnumeric") + (exit)) + (let ((tmpf (create-temporary-file (pathname-strip-directory fname)))) + (system (conc " gunzip > " tmpf " < " fname)) + (let ((res (refdb:read-gnumeric-xml tmpf))) + (delete-file tmpf) + res)))) + +(define (import-gnumeric-file fname targdir) + (extract-refdb (read-gnumeric-file fname) targdir)) + +;; Write a gnumeric compressed xml spreadsheet from a refdb directory structure. +;; +(define (refdb-export dbdir fname) + (let* ((sxml-dat (refdb->sxml dbdir)) + (tmpf (create-temporary-file (pathname-strip-directory fname))) + (tmpgzf (conc tmpf ".gz"))) + (with-output-to-file tmpf + (lambda () + (print (sxml-serializer#serialize-sxml sxml-dat ns-prefixes: (list (cons 'gnm "http://www.gnumeric.org/v10.dtd")))))) + (system (conc "gzip " tmpf)) + (file-copy tmpgzf fname #t) + (delete-file tmpgzf))) + +(define (hash-table-reverse-lookup ht val) + (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f)) + +(define (read-dat fname) + (let ((section-rx (regexp "^\\[(.*)\\]\\s*$")) + (comment-rx (regexp "^#.*")) ;; This means a cell name cannot start with # + (quoted-cell-rx (regexp "^\"([^\"]*)\" (.*)$")) + (cell-rx (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator + (blank-rx (regexp "^\\s*$")) + (continue-rx (regexp ".*\\\\$")) + (var-no-val-rx (regexp "^(\\S+)\\s*$")) + (inp (open-input-file fname)) + (cmnt-indx (make-hash-table)) + (blnk-indx (make-hash-table)) + (first-section #f)) ;; used for zeroth title + (let loop ((inl (read-line inp)) + (section ".............") + (res '())) + (if (eof-object? inl) + (begin + (close-input-port inp) + (cons (list first-section first-section first-section) + (reverse res))) + (regex-case + inl + (continue-rx _ (loop (conc inl (read-line inp)) section res)) + (comment-rx _ (let ((curr-indx (+ 1 (hash-table-ref/default cmnt-indx section 0)))) + (hash-table-set! cmnt-indx section curr-indx) + (loop (read-line inp) + section + (cons (list (conc "#CMNT" curr-indx) section inl) res)))) + (blank-rx _ (let ((curr-indx (+ 1 (hash-table-ref/default blnk-indx section 0)))) + (hash-table-set! blnk-indx section curr-indx) + (loop (read-line inp) + section + (cons (list (conc "#BLNK" curr-indx) section " ") res)))) + (section-rx (x sname) (begin + (if (not first-section) + (set! first-section sname)) + (loop (read-line inp) + sname + res))) + (quoted-cell-rx (x k v)(loop (read-line inp) + section + (cons (list k section v) res))) + (cell-rx (x k v) (loop (read-line inp) + section + (cons (list k section v) res))) + (var-no-val-rx (x k) (loop (read-line inp) + section + (cons (list k section "") res))) + (else (begin + (print "ERROR: Unrecognised line in input file " fname ", ignoring it") + (loop (read-line inp) section res)))))))) + +(define (get-value-type val expressions) + (cond + ((not val) '(ValueType "60")) + ((string->number val) '(ValueType "40")) + ((equal? val "") '(ValueType "60")) + ((equal? (substring val 0 1) "=") + (let ((exid (hash-table-ref/default expressions val #f))) + (if exid + (list 'ExprID exid) + (let* ((values (hash-table-keys expressions)) ;; note, values are the id numbers + (new-max (+ 1 (if (null? values) 0 (apply max values))))) + (hash-table-set! expressions val new-max) + (list 'ExprID new-max))))) + (else '(ValueType "60")))) + +(define (dat->cells dat) + (let* ((indx (common:sparse-list-generate-index (cdr dat))) + (row-indx (car indx)) + (col-indx (cadr indx)) + (rowdat (map (lambda (row)(list (car row) " " (car row))) row-indx)) + (coldat (map (lambda (col)(list " " (car col) (car col))) col-indx)) + (exprs (make-hash-table))) + (list (cons 'http://www.gnumeric.org/v10.dtd:Cells + (map (lambda (item) + (let* ((row-name (car item)) + (col-name (cadr item)) + (row-num (let ((i (assoc row-name row-indx))) + (if i (cadr i) 0))) ;; 0 for the title row/col + (col-num (let ((i (assoc col-name col-indx))) + (if i (cadr i) 0))) + (value (caddr item)) + (val-type (get-value-type value exprs))) + (list 'http://www.gnumeric.org/v10.dtd:Cell + (list '@ val-type (list 'Row (conc row-num)) (list 'Col (conc col-num))) + value))) + (append rowdat coldat dat)))))) + +(define (refdb->sxml dbdir) + (let* ((sht-names (read-file (conc dbdir "/sheet-names.cfg") read-line)) + (wrk-rem (file->sxml (conc dbdir "/sxml/_workbook.sxml"))) + (sht-rem (file->sxml (conc dbdir "/sxml/_sheets.sxml"))) + (sheets (fold (lambda (sheetname res) + (let* ((sheetdat (read-dat (conc dbdir "/" sheetname ".dat"))) + (cells (dat->cells sheetdat)) + (sht-meta (file->sxml (conc dbdir "/sxml/" sheetname ".sxml")))) + (cons (cons (car sht-meta) + (append (cons (list 'http://www.gnumeric.org/v10.dtd:Name sheetname) + (cdr sht-meta)) + cells)) + res))) + '() + (reverse sht-names)))) + (append wrk-rem (list (append + (cons 'http://www.gnumeric.org/v10.dtd:Workbook + sht-rem) + (list (cons 'http://www.gnumeric.org/v10.dtd:Sheets sheets))))))) + +;; (define ( + +;; +;; optional apply proc to rownum colnum value +;; +;; NB// If a change is made to this routine please look also at applying +;; it to the code in Megatest (http://www.kiatoa.com/fossils/megatest) +;; in the file common.scm +;; +(define (common:sparse-list-generate-index data #!key (proc #f)) + (if (null? data) + (list '() '()) + (let loop ((hed (car data)) + (tal (cdr data)) + (rownames '()) + (colnames '()) + (rownum 0) + (colnum 0)) + (let* ((rowkey (car hed)) + (colkey (cadr hed)) + (value (caddr hed)) + (existing-rowdat (assoc rowkey rownames)) + (existing-coldat (assoc colkey colnames)) + (curr-rownum (if existing-rowdat rownum (+ rownum 1))) + (curr-colnum (if existing-coldat colnum (+ colnum 1))) + (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) + (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) + ;; (debug:print-info 0 "Processing record: " hed ) + (if proc (proc curr-rownum curr-colnum rowkey colkey value)) + (if (null? tal) + (list new-rownames new-colnames) + (loop (car tal) + (cdr tal) + new-rownames + new-colnames + (if (> curr-rownum rownum) curr-rownum rownum) + (if (> curr-colnum colnum) curr-colnum colnum) + )))))) +(define help + (conc "Usage: refdb action params ... + +Note: refdbdir is a path to the directory containg sheet-names.cfg + + import filename.gnumeric refdbdir : Import a gnumeric file into a txt db directory + export refdbdir filename.gnumeric : Export a refdb to a gnumeric file + edit refdbdir : Edit a refdbdir using gnumeric. + ls refdbdir : List the keys for specified level + lookup refdbdir sheetname row col : Look up a value in the text db + getrownames refdb sheetname : Get a list of row titles + getcolnames refdb sheetname : Get a list of column titles + +To export to other formats; first export to gnumeric then use ssconvert. + +e.g. + +refdb export mydata mydata.gnumeric +ssconvert -T Gnumeric_html:html40 mydata.gnumeric mydata.html + +Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) + +(define (list-sheets path) + ;; (cond + ;; ((and path (not sheet)(not row)(not col)) + (if (file-exists? path) + (read-file (conc path "/sheet-names.cfg") read-line) + '())) +;; ((and path sheet (not row)(not col)) + +(define (lookup path sheet row col) + (let ((fname (conc path "/" sheet ".dat"))) + (if (file-exists? fname) + (let ((dat (read-dat fname))) + (if (null? dat) + #f + (let loop ((hed (car dat)) + (tal (cdr dat))) + (if (and (equal? row (car hed)) + (equal? col (cadr hed))) + (caddr hed) + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + #f))) + +;; call with proc = car to get row names +;; call with proc = cadr to get col names +(define (get-rowcol-names path sheet proc) + (let ((fname (conc path "/" sheet ".dat")) + (cmnt-rx (regexp "^#CMNT\\d+\\s*")) + (blnk-rx (regexp "^#BLNK\\d+\\s*"))) + (if (file-exists? fname) + (let ((dat (read-dat fname))) + (if (null? dat) + '() + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '())) + (let* ((row-name (proc hed)) + (newres (if (and (not (member row-name res)) + (not (string-search cmnt-rx row-name)) + (not (string-search blnk-rx row-name))) + (cons row-name res) + res))) + (if (null? tal) + (reverse newres) + (loop (car tal)(cdr tal) newres)))))) + '()))) + +;; (define (get-col-names path sheet) +;; (let ((fname (conc path "/" sheet ".dat"))) +;; (if (file-exists? fname) +;; (let ((dat (read-dat fname))) +;; (if (null? dat) +;; #f +;; (map cadr dat)))))) + +(define (edit-refdb path) + ;; TEMPORARY, REMOVE IN 2014 + (if (not (file-exists? path)) ;; Create new + (begin + (print "\nINFO: Creating new txtdb at " path "\n") + (create-new-db path))) + (if (not (file-exists? (conc path "/sxml/_sheets.sxml"))) + (begin + (print "ERROR: You appear to have the old file structure for txtdb. Please do the following and try again.") + (print) + (print "mv " path "/sxml/sheets.sxml " path "/sxml/_sheets.sxml") + (print "mv " path "/sxml/workbook.sxml " path "/sxml/_workbook.sxml") + (print) + (print "Don't forget to remove the old files from your revision control system and add the new.") + (exit))) + (let* ((dbname (pathname-strip-directory path)) + (tmpf (conc (create-temporary-file dbname) ".gnumeric"))) + (if (file-exists? (conc path "/sheet-names.cfg")) + (refdb-export path tmpf)) + (let* ((pid (process-run "gnumeric" (list tmpf)))) + (let loop ((last-mod-time (current-seconds))) + (let-values (((pid-code exit-status exit-signal)(process-wait pid #t))) + (if (eq? pid-code 0) ;; still going + (if (file-exists? tmpf) + (let ((mod-time (file-modification-time tmpf))) + (if (> mod-time last-mod-time) + (begin + (print "saved data to " path) + (import-gnumeric-file tmpf path))) + (thread-sleep! 0.5) + (loop mod-time)) + (begin + (thread-sleep! 0.5) + (loop last-mod-time)))))) + ;; all done + (print "all done, writing new data to " path) + (import-gnumeric-file tmpf path) + (print "data written, exiting refdb edit.")))) + +;;====================================================================== +;; This routine dispaches or executes most of the commands for refdb +;;====================================================================== +;; +(define (process-action action-str . param) + (let ((num-params (length param)) + (action (string->symbol action-str))) + (cond + ((eq? num-params 1) + (case action + ((edit) + (edit-refdb (car param))) + ((ls) + (map print (list-sheets (car param)))))) + ((eq? num-params 2) + (let ((param1 (car param)) + (param2 (cadr param))) + (case action + ((getrownames) (print (string-intersperse (get-rowcol-names param1 param2 car) " "))) + ((getcolnames) (print (string-intersperse (get-rowcol-names param1 param2 cadr) " "))) + ((import) (import-gnumeric-file param1 param2)) ;; fname targname + ((export) (refdb-export param1 param2)) + (else (print "Unrecognised command " action)(print help))))) + ((eq? num-params 4) + (case action + ((lookup) ;; path section row col + (let ((res (lookup (car param)(cadr param)(caddr param)(cadddr param)))) + (if res + (print res) + (begin + (print "") + (exit 1)))))))))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args))) + (cond + ((null? rema)(print help)) + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((mtedit) ;; Edit a Megatest area + (megatest->refdb)))) + ((>= (length rema) 2) + (apply process-action (car rema)(cdr rema))) + (else (print help))))) + +;;====================================================================== +;; C R E A T E N E W D B S +;;====================================================================== + +(include "metadat.scm") + +;; Creates a new db at path with one sheet +(define (create-new-db path) + (extract-refdb minimal-sxml path)) + +;;====================================================================== +;; M E G A T E S T S U P P O R T +;;====================================================================== + +;; Construct a temporary refdb area from the files in a Megatest area +;; +;; .refdb +;; megatest.dat (from megatest.config) +;; runconfigs.dat (from runconfigs.config) +;; tests_test1.dat (from tests/test1/testconfig) +;; etc. +;; + +(define (make-sheet-meta-if-needed fname) + (if (not (file-exists? fname)) + (sxml->file sheet-meta fname))) + +(define (megatest->refdb) + (if (not (file-exists? "megatest.config")) ;; must be at top of Megatest area + (begin + (print "ERROR: Must be at top of Megatest area to edit") + (exit))) + (create-directory ".refdb/sxml" #t) + (if (not (file-exists? ".refdb/sxml/_workbook.sxml")) + (sxml->file workbook-meta ".refdb/sxml/_workbook.sxml")) + (file-copy "megatest.config" ".refdb/megatest.dat" #t) + (make-sheet-meta-if-needed ".refdb/sxml/megatest.sxml") + (file-copy "runconfigs.config" ".refdb/runconfigs.dat" #t) + (make-sheet-meta-if-needed ".refdb/sxml/runconfigs.sxml") + (let ((testnames '())) + (for-each (lambda (tdir) + (let* ((testname (pathname-strip-directory tdir)) + (tconfig (conc tdir "/testconfig")) + (metafile (conc ".refdb/sxml/" testname ".sxml"))) + (if (file-exists? tconfig) + (begin + (set! testnames (append testnames (list testname))) + (file-copy tconfig (conc ".refdb/" testname ".dat") #t) + (make-sheet-meta-if-needed metafile))))) + (glob "tests/*")) + (let ((sheet-names (append (list "megatest" "runconfigs") testnames))) + (if (not (file-exists? ".refdb/sxml/_sheets.sxml")) + (sxml->file (replace-sheet-name-index sheets-meta sheet-names) ".refdb/sxml/_sheets.sxml")) + (with-output-to-file ".refdb/sheet-names.cfg" + (lambda () + (map print sheet-names)))))) + +(let ((dotfile (conc (get-environment-variable "HOME") "/.txtdbrc"))) + (if (file-exists? dotfile) + (load dotfile))) + +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.refdbrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(main) + +#| + (define x (refdb:read-gnumeric-xml "testdata-stripped.xml")) + + + +;; Write out sxml +(with-output-to-file "testdata.sxml" (lambda()(pp x))) + ;; (serialize-sxml a output: "new.xml") +(with-output-to-file "testdata-stripped.xml" (lambda ()(print (sxml-serializer#serialize-sxml y)))) + +;; Read in sxml file +(with-input-from-file "testdata.sxml" (lambda ()(set! y (read)))) + +(find-section x 'http://www.gnumeric.org/v10.dtd:Workbook) + +(define sheets (find-section x 'http://www.gnumeric.org/v10.dtd:Sheets)) + +(define sheet1 (car sheets)) +(define cells-sheet1 (find-section sheet1 'http://www.gnumeric.org/v10.dtd:Cells)) +(map (lambda (c)(find-section c 'Row)) cells-sheet1) + +(for-each (lambda (cell) + (let* ((len (length cell)) + (row (car (find-section cell 'Row))) + (col (car (find-section cell 'Col))) + (val (let ((res (cdr (filter (lambda (x)(not (list? x))) cell)))) + (if (null? res) "" (car res))))) + (print "Row=" row " col=" col " val=" val))) + cells-sheet1) + + +(map (lambda (c)(filter (lambda (x)(not (list? x))) c)) cells-sheet1) +|# ADDED utils/Makefile.installall Index: utils/Makefile.installall ================================================================== --- /dev/null +++ utils/Makefile.installall @@ -0,0 +1,207 @@ + +# Copyright 2013,2014 Matthew Welland. +# +# This program is made available under the GNU GPL version 2.0 or +# greater. See the accompanying file COPYING for details. +# +# This program is distributed WITHOUT ANY WARRANTY; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +# PURPOSE. + +# make PREFIX=/mfs/pkgs/chicken/chicken-core all + +help : + @echo You may need to do the following first: + @echo sudo apt-get install libreadline-dev + @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison + @echo sudo apt-get install libmotif3 + @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) + @echo You are using PREFIX=$(PREFIX) + @echo You are using PROXY="$(PROXY)" + @echo If needed set PROXY to host.dom:port + @echo http_proxy=$(http_proxy) + @echo PROX=$(PROX) + @echo + @echo To make all do: make all + +# Put the installation here +ifeq ($(PREFIX),) +PREFIX=$(PWD)/target +endif + +# Set this on the command line of your make call if needed: make PROXY=host.com:1234 +PROXY= + +# Select version of chicken, sqlite3 etc +CHICKEN_VERSION=4.9.0.1 +SQLITE3_VERSION=3080500 +# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz + +# Override IUPBRANCH to use other than trunk +IUPBRANCH=iup-3.10.1 + +# Eggs to install (straightforward ones) +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ + dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ + srfi-19 refdb ini-file + +# +# Derived variables +# + +ifeq ($(PROXY),) +PROX:= +else +http_proxy:=http://$(PROXY) +PROX:=-proxy $(PROXY) +endif + +BUILDHOME=$(PWD) +PATH:=$(PREFIX)/bin:$(PATH) +LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) +LD_LIBRARY_PATH=$(LIBPATH) +CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/6 + +VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags + +vpath %.so $(CHICKEN_EGG_DIR) +vpath %.flag eggflags + +EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) +EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS))) + +# Stuff needed for IUP +ISARCHX86_64=$(shell uname -a | grep x86_64) +ifeq ($(ISARCHX86_64),) +ARCHSIZE= +else +ARCHSIZE=64_ +endif + +CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)" +# CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) + +all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs + +chkn : $(CHICKEN_INSTALL) + +eggs : $(EGGSOFILES) + +libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +logprobin : $(PREFIX)/bin/logpro + +$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so + $(CHICKEN_INSTALL) logpro + +# Silly rule to make installing eggs more makeish, I don't understand why I need the basename +$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag + $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) + +$(EGGFLAGS) : # $(CHICKEN_INSTALL) + mkdir -p eggflags + touch $(EGGFLAGS) + +# some setup stuff +# +setup-chicken4x.sh : $(EGGFLAGS) + (echo "export PATH=$(PATH)" > setup-chicken4x.sh) + (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh) + mkdir -p $(PREFIX) + +chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz + tar xfz chicken-$(CHICKEN_VERSION).tar.gz + ln -sf chicken-$(CHICKEN_VERSION) chicken-core + + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + +chicken-4.9.0.1.tar.gz : + wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz + +# git clone git://code.call-cc.org/chicken-core +# git clone http://code.call-cc.org/git/chicken-core.git + +$(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + +#====================================================================== +# S Q L I T E 3 +#====================================================================== + +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log + cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install + +$(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3 + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 + +#====================================================================== +# M A T T S U T I L S +#====================================================================== + +opensrc.fossil : + fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + +opensrc/histstore/histstore.scm : opensrc.fossil + mkdir -p opensrc + cd opensrc;fossil open ../opensrc.fossil + +opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(PREFIX)/lib/sqlite3.so + cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + +$(PREFIX)/bin/hs : opensrc/histstore/hs + cp -f opensrc/histstore/hs $(PREFIX)/bin/hs + +#====================================================================== +# I U P +#====================================================================== + +ffcall.fossil : + fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + +ffcall/README : ffcall.fossil + mkdir -p ffcall + cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi + +# NOTE: This worked fine *without* the enable-shared +# +$(PREFIX)/lib/libavcall.a : ffcall/README + cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install + +iuplib.fossil : + fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + +iup/installall.sh : iuplib.fossil + mkdir -p iup + cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + +iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so + cd iup && ./makeall.sh + +$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone + cd iup && ./installall.sh + +# $(PREFIX)/lib/libiup.so : iup/iup/alldone +# touch -c $(PREFIX)/lib/libiup.so + +$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + +$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so + CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + + +clean : + rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -1,10 +1,10 @@ #! /usr/bin/env bash # set -x -# Copyright 2007-2010, Matthew Welland. +# Copyright 2007-2014, Matthew Welland. # # This program is made available under the GNU GPL version 2.0 or # greater. See the accompanying file COPYING for details. # # This program is distributed WITHOUT ANY WARRANTY; without even the @@ -14,15 +14,25 @@ echo You may need to do the following first: echo sudo apt-get install libreadline-dev echo sudo apt-get install libwebkitgtk-dev echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 echo KTYPE can be 26, 26g4, or 32 +echo echo KTYPE=$KTYPE echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" + +# NOTES: +# +# Centos with security setup may need to do commands such as following as root: +# +# NB// fix the paths first +# +# for a in /localdisk/chicken/4.8.0/lib/*.so;do chcon -t textrel_shlib_t $a; done + echo ADDITIONAL_LIBPATH=$ADDITIONAL_LIBPATH echo echo To use previous IUP libraries set USEOLDIUP to yes echo USEOLDIUP=$USEOLDIUP echo @@ -49,13 +59,20 @@ export KTYPE=26 else echo Using KTYPE=$KTYPE fi -export CHICKEN_VERSION=4.8.0 -if ! [[ -e chicken-${CHICKEN_VERSION}.tar.gz ]]; then - wget http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz +# Put all the downloaded tar files in tgz +mkdir -p tgz + +# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz +export CHICKEN_VERSION=4.8.0.5 +export CHICKEN_BASEVER=4.8.0 +chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz +if ! [[ -e tgz/$chicken_targz ]]; then + wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz} + mv $chicken_targz tgz fi BUILDHOME=$PWD DEPLOYTARG=$BUILDHOME/deploy @@ -72,21 +89,21 @@ echo PATH=$PATH echo LD_LIBRARY_PATH=$LD_LIBRARY_PATH if ! [[ -e $PREFIX/bin/csi ]]; then - tar xfvz chicken-${CHICKEN_VERSION}.tar.gz + tar xfvz tgz/$chicken_targz cd chicken-${CHICKEN_VERSION} # make PLATFORM=linux PREFIX=$PREFIX spotless make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do -$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars +$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing ssax sxml-serializer sxml-modifications logpro # if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then # $CHICKEN_INSTALL $PROX $f # # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f # else # echo Skipping install of egg $f as it is already installed @@ -103,56 +120,65 @@ export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH export LD_LIBRARY_PATH=$LIBPATH export SQLITE3_VERSION=3071401 echo Install sqlite3 -if ! [[ -e sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then - wget http://www.sqlite.org/sqlite-autoconf-$SQLITE3_VERSION.tar.gz +sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz +if ! [[ -e tgz/$sqlite3_tgz ]]; then + wget http://www.sqlite.org/$sqlite3_tgz + mv $sqlite3_tgz tgz fi if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then - if [[ -e sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then - tar xfz sqlite-autoconf-$SQLITE3_VERSION.tar.gz + if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then + tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) # CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL -prefix $DEPLOYTARG -deploy $PROX sqlite3 CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX sqlite3 fi fi # $CHICKEN_INSTALL $PROX sqlite3 + +# IUP versions +CDVER=5.7 +IUPVER=3.8 +IMVER=3.8 if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ fi # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz" if [[ x$USEOLDIUP == "x" ]];then - export files="cd-5.5.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.8_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.6_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" + export files="cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" else echo WARNING: Using old IUP libraries export files="cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" fi mkdir -p $PREFIX/iuplib for a in `echo $files` ; do - if ! [[ -e $a ]] ; then + if ! [[ -e tgz/$a ]] ; then wget http://www.kiatoa.com/matt/iup/$a fi - echo Untarring $a into $BUILDHOME/lib - (cd $PREFIX/lib;tar xfvz $BUILDHOME/$a;mv include/* ../include) + mv $a tgz/$a + echo Untarring tgz/$a into $BUILDHOME/lib + (cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include) # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a) done # ffcall obtained from: # cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall -if ! [[ -e ffcall.tar.gz ]] ; then +if ! [[ -e tgz/ffcall.tar.gz ]] ; then wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz + mv ffcall.tar.gz tgz fi -tar xfvz ffcall.tar.gz +tar xfvz tgz/ffcall.tar.gz cd ffcall ./configure --prefix=$PREFIX --enable-shared make make install @@ -164,138 +190,19 @@ # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup # iup:1.0.2 CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw -# disabled zmq # #====================================================================== -# disabled zmq # # Note uuid needed only for zmq 2.x series -# disabled zmq # #====================================================================== -# disabled zmq # -# disabled zmq # # http://download.zeromq.org/zeromq-3.2.1-rc2.tar.gz -# disabled zmq # # zpatchlev=-rc2 -# disabled zmq # # http://download.zeromq.org/zeromq-2.2.0.tar.gz -# disabled zmq # -# disabled zmq # if [[ -e /usr/lib/libzmq.so ]]; then -# disabled zmq # echo "Using system installed zmq library" -# disabled zmq # $CHICKEN_INSTALL zmq -# disabled zmq # else -# disabled zmq # ZEROMQ=zeromq-2.2.0 -# disabled zmq # # ZEROMQ=zeromq-3.2.2 -# disabled zmq # -# disabled zmq # # wget http://www.kernel.org/pub/linux/utils/util-linux/v2.22/util-linux-2.22.tar.gz -# disabled zmq # UTIL_LINUX=2.21 -# disabled zmq # # UTIL_LINUX=2.20.1 -# disabled zmq # if ! [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then -# disabled zmq # # wget http://www.kiatoa.com/matt/util-linux-2.20.1.tar.gz -# disabled zmq # wget http://www.kernel.org/pub/linux/utils/util-linux/v${UTIL_LINUX}/util-linux-${UTIL_LINUX}.tar.gz -# disabled zmq # fi -# disabled zmq # -# disabled zmq # if [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then -# disabled zmq # tar xfz util-linux-${UTIL_LINUX}.tar.gz -# disabled zmq # cd util-linux-${UTIL_LINUX} -# disabled zmq # mkdir -p build -# disabled zmq # cd build -# disabled zmq # if [[ $UTIL_LINUX = "2.22" ]] ; then -# disabled zmq # ../configure --prefix=$PREFIX \ -# disabled zmq # --enable-shared \ -# disabled zmq # --disable-use-tty-group \ -# disabled zmq # --disable-makeinstall-chown \ -# disabled zmq # --disable-makeinstall-setuid \ -# disabled zmq # --disable-libtool-lock \ -# disabled zmq # --disable-login \ -# disabled zmq # --disable-sulogin \ -# disabled zmq # --disable-su \ -# disabled zmq # --disable-schedutils \ -# disabled zmq # --disable-libmount \ -# disabled zmq # --disable-mount \ -# disabled zmq # --disable-losetup \ -# disabled zmq # --disable-fsck \ -# disabled zmq # --disable-partx \ -# disabled zmq # --disable-mountpoint \ -# disabled zmq # --disable-fallocate \ -# disabled zmq # --disable-unshare \ -# disabled zmq # --disable-eject \ -# disabled zmq # --disable-agetty \ -# disabled zmq # --disable-cramfs \ -# disabled zmq # --disable-switch_root \ -# disabled zmq # --disable-pivot_root \ -# disabled zmq # --disable-kill \ -# disabled zmq # --disable-libblkid \ -# disabled zmq # --disable-utmpdump \ -# disabled zmq # --disable-rename \ -# disabled zmq # --disable-chsh-only-listed \ -# disabled zmq # --disable-wall \ -# disabled zmq # --disable-pg-bell \ -# disabled zmq # --disable-require-password \ -# disabled zmq # --disable-libtool-lock \ -# disabled zmq # --disable-nls \ -# disabled zmq # --disable-dmesg \ -# disabled zmq # --without-ncurses -# disabled zmq # else -# disabled zmq # ../configure --prefix=$PREFIX \ -# disabled zmq # --enable-shared \ -# disabled zmq # --disable-mount \ -# disabled zmq # --disable-fsck \ -# disabled zmq # --disable-partx \ -# disabled zmq # --disable-largefile \ -# disabled zmq # --disable-tls \ -# disabled zmq # --disable-libmount \ -# disabled zmq # --disable-mountpoint \ -# disabled zmq # --disable-nls \ -# disabled zmq # --disable-rpath \ -# disabled zmq # --disable-agetty \ -# disabled zmq # --disable-cramfs \ -# disabled zmq # --disable-switch_root \ -# disabled zmq # --disable-pivot_root \ -# disabled zmq # --disable-fallocate \ -# disabled zmq # --disable-unshare \ -# disabled zmq # --disable-rename \ -# disabled zmq # --disable-schedutils \ -# disabled zmq # --disable-libblkid \ -# disabled zmq # --disable-wall CFLAGS='-fPIC' -# disabled zmq # -# disabled zmq # # --disable-makeinstall-chown \ -# disabled zmq # # --disable-makeinstall-setuid \ -# disabled zmq # -# disabled zmq # # --disable-chsh-only-listed -# disabled zmq # # --disable-pg-bell let pg not ring the bell on invalid keys -# disabled zmq # # --disable-require-password -# disabled zmq # # --disable-use-tty-group do not install wall and write setgid tty -# disabled zmq # # --disable-makeinstall-chown -# disabled zmq # # --disable-makeinstall-setuid -# disabled zmq # fi -# disabled zmq # -# disabled zmq # (cd libuuid;make install) -# disabled zmq # # make -# disabled zmq # # make install -# disabled zmq # cp $PREFIX/include/uuid/uuid.h $PREFIX/include/uuid.h -# disabled zmq # fi -# disabled zmq # -# disabled zmq # -# disabled zmq # cd $BUILDHOME -# disabled zmq # -# disabled zmq # if ! [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then -# disabled zmq # wget http://download.zeromq.org/${ZEROMQ}${zpatchlev}.tar.gz -# disabled zmq # fi -# disabled zmq # -# disabled zmq # if [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then -# disabled zmq # tar xfz ${ZEROMQ}.tar.gz -# disabled zmq # cd ${ZEROMQ} -# disabled zmq # ln -s $PREFIX/include/uuid src -# disabled zmq # # LDFLAGS=-L$PREFIX/lib ./configure --prefix=$PREFIX -# disabled zmq # -# disabled zmq # ./configure --enable-static --prefix=$PREFIX --with-uuid=$PREFIX LDFLAGS="-L$PREFIX/lib" CPPFLAGS="-fPIC -I$PREFIX/include" LIBS="-lgcc" -# disabled zmq # # --disable-shared CPPFLAGS="-fPIC -# disabled zmq # # LDFLAGS="-L/usr/lib64 -L$PREFIX/lib" ./configure --enable-static --prefix=$PREFIX -# disabled zmq # make -# disabled zmq # make install -# disabled zmq # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX zmq -# disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq -# disabled zmq # fi -# disabled zmq # fi # if zmq is in /usr/lib -# disabled zmq # +# NB// Removed bunch of zmq compiling tricks. Look at older versions of this file if you need to recreate... + cd $BUILDHOME + +git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 +cd zmq-3.2 +chicken-install + +cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 ## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 @@ -324,5 +231,8 @@ # cd "Canvas Draw-$CD_REL/chicken" # CSC_OPTIONS="-I$PREFIX/include -L$LIBPATH" $CHICKEN_INSTALL $PROX -D no-library-checks echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh echo file can be found in the current directory which should work for setting up to run chicken4x + +echo Testing iup +$PREFIX/bin/csi -b -eval '(use iup)(print "Success")' ADDED utils/installck.sh Index: utils/installck.sh ================================================================== --- /dev/null +++ utils/installck.sh @@ -0,0 +1,22 @@ +#!/bin/bash + +myhome=$(dirname $0) + +if [[ $proxy == "" ]]; then + echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' + echo PROX="" +else + export http_proxy=http://$proxy + export PROX="-proxy $proxy" +fi + +if [[ -z $PREFIX ]];then + echo "\$PREFIX variable is required" + exit +fi + +export LD_LIBRARY_NAME=$PREFIX/lib + +logname=$(basename $PREFIX) + +script -c "make -f $myhome/Makefile_latest.installall all" $logname.log ADDED utils/loadrunner Index: utils/loadrunner ================================================================== --- /dev/null +++ utils/loadrunner @@ -0,0 +1,78 @@ +#!/bin/bash + +LOADRUNNER=$0 + +# load=`uptime|awk '{print $10}'|cut -d, -f1` +load=$(uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/') +load2=$(uptime|perl -pe 's/.*: (\d+.\d+), (\d+.\d+),.*/$2/') +# echo "load2=$load2, load=$load" + +# Run a job detached from stdin/stdout (i.e. daemonized) +# Launch on remotehost if specified by TARGETHOST +# +function launchjob () { + # Can't always trust $PWD + CURRWD=`pwd` + if [[ $TARGETHOST_LOGF == "" ]]; then + TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T` + fi + # echo "#======================================================================" + # echo "# NBFAKE Running command:" + # echo "# \"$*\"" + # echo "#======================================================================" + + if [[ $TARGETHOST == "" ]]; then + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &" + else + ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\"" + fi +} + +function get_delay_time () { + RANGE=$1 + number=$RANDOM + let "number %= $RANGE" + echo $number +} + +if which cpucheck > /dev/null;then + numcpu=`cpucheck|tail -1|awk '{print $6}'` +elif which lscpu > /dev/null;then + numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` +else + numcpu=2 +fi + +# NB// max_load is in units of percent. +# +lperc=$(echo "100 * $load / $numcpu"|bc) +lperc2=$(echo "100 * $load2 / $numcpu"|bc) +let "lperc2adj=$lperc2 + $numcpu" +if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then + max_load=100 +else + max_load=$MAX_ALLOWED_LOAD +fi + +lfile=/tmp/loadrunner-$USER.lockfile +lockfile -r 5 -l 60 $lfile &> /dev/null + +if [[ $lperc -lt $max_load ]];then + if [[ $lperc -le $lperc2adj ]];then + # echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD % and $lperc2 < $lperc" + # echo "Starting command: \"$@\"" + launchjob "$@" + # we sleep ten seconds here to keep the lock a little longer and give time for + # the uptime to show a response + # sleep 2 + else + echo "$LOADRUNNER $@" | at now + 2 minutes &> /dev/null + # sleep 5 + fi +else + # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\"" + echo "$LOADRUNNER $@" | at now + 2 minutes &> /dev/null +fi + +sleep $(get_delay_time 3) +rm -f $lfile ADDED utils/loadrunner.scm.notfinished Index: utils/loadrunner.scm.notfinished ================================================================== --- /dev/null +++ utils/loadrunner.scm.notfinished @@ -0,0 +1,192 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use ssax) +(use sxml-serializer) +(use sxml-modifications) +(use regex) +(use srfi-69) +(use regex-case) +(use posix) +(use json) +(use csv) +(use srfi-18) +(use format) + +(require-library iup) +(import (prefix iup iup:)) +(require-library ini-file) +(import (prefix ini-file ini:)) + +(use canvas-draw) +(import canvas-draw-iup) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(include "megatest-fossil-hash.scm") + +;; +;; GLOBALS +;; +(define *loadrunner:current-tab-number* 0) +(define loadrunner:unrecognised-command "ERROR: Unrecognised command or missing params. Try \"loadrunner help\"") +(define loadrunner:help (conc "Usage: loadrunner [action [params ...]] + +Note: run loadrunner without parameters to start the gui. + + run cmd [params ..] : Run cmd params ... when system load drops + process : Process the queue + +Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) ;; " + +;;====================================================================== +;; DB +;;====================================================================== + +(define (loadrunner:initialize-db db) + (for-each + (lambda (qry) + (sqlite3:execute db qry)) + (list + "CREATE TABLE pkgs + (id INTEGER PRIMARY KEY, + cmd TEXT, + datetime TEXT);"))) + +;; Create the sqlite db +(define (loadrunner:open-db path) + (if (and path + (directory? path) + (file-read-access? path)) + (let* ((dbpath (conc path "/loadrunner.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath)) + (handler (make-busy-timeout 136000))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit)) + (set! db (sqlite3:open-database dbpath))) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (if (not dbexists) + (begin + (loadrunner:initialize-db db))) + db))) + +;;====================================================================== +;; GUI +;;====================================================================== + +;; The main menu +(define (loadrunner:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +(define (loadrunner:publish-view) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (loadrunner:get-view) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (loadrunner:manage-view) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (loadrunner:gui) + (iup:show + (iup:dialog + #:title (conc "Loadrunner dashboard " (current-user-name) ":" (current-directory)) + #:menu (loadrunner:main-menu) + (let* ((tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *loadrunner:current-tab-number* curr)) + (loadrunner:publish-view) + (loadrunner:get-view) + (loadrunner:manage-view) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Publish") + (iup:attribute-set! tabs "TABTITLE1" "Get") + (iup:attribute-set! tabs "TABTITLE2" "Manage") + ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + tabs))) + (iup:main-loop)) + +;;====================================================================== +;; MAIN +;;====================================================================== + +(define (loadrunner:load-config path) + (let ((fname (conc path "/.loadrunner.config"))) + (ini:property-separator-patt " * *") + (ini:property-separator #\space) + (if (file-exists? fname) + (ini:read fname) + '()))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (conf (loadrunner:load-config (pathname-directory prog)))) + ;; ( ????? + (cond + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((process)(loadrunner:process-queue)) + ((pause) + (loadrunner:pause-queue (cdr rema))) + ((help -h -help --h --help) + (print loadrunner:help)) + (else + (print loadrunner:unrecognised-command)))) + ((null? rema)(loadrunner:gui)) + ((>= (length rema) 2) + (case (string->symbol (car rema)) + ((run) + (loadrunner:process-cmd (cdr rema))) + ((remove) + (loadrunner:remove-cmds (cdr rema))) + (else + (print loadrunner:unrecognised-command)))) + (else (print loadrunner:unrecognised-command))))) + +(main) Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -1,16 +1,26 @@ #!/bin/bash prefix=$1 cmd=$2 +target=$3 -echo "#!/bin/bash" if [ "$LD_LIBRARY_PATH" != "" ];then + cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 - echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" +( cat << __EOF +if [ "\$LD_LIBRARY_PATH" != "" ];then + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH +else + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH +fi +__EOF +) > $cfgfile + echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi -fullcmd="$prefix/bin/$cmd" +echo "#!/bin/bash" > $target +echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target +echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target -echo "$fullcmd \"\$@\"" Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -1,13 +1,17 @@ #!/bin/bash usage="mt_ezstep stepname prevstepname command [args ...]" if [ "$MT_CMDINFO" == "" ];then - echo "ERROR: $0 should be run within a megatest test environment" - echo "Usage: $usage" - exit + if [ -e megatest.sh ];then + source megatest.sh + else + echo "ERROR: $0 should be run within a megatest test environment" + echo "Usage: $usage" + exit + fi fi # Purpose: This is for the [ezsteps] secton in your testconfig file. # DO NOT USE IN YOUR SCRIPTS! # @@ -68,7 +72,7 @@ exitstatus=1 else exitstatus=0 fi -$MT_MEGATEST -env2file .ezsteps/${stepname} +# $MT_MEGATEST -env2file .ezsteps/${stepname} exit $exitstatus ADDED utils/mt_xterm Index: utils/mt_xterm ================================================================== --- /dev/null +++ utils/mt_xterm @@ -0,0 +1,14 @@ +#!/bin/bash + +MT_TMPDISPLAY=$DISPLAY +if [ -e megatest.sh ];then + source megatest.sh +fi +export DISPLAY=$MT_TMPDISPLAY + +if [ x"$MT_XTERM_CMD" == "x" ];then + exec xterm "$@" +else + exec $MT_XTERM_CMD +fi + ADDED utils/mtgetfile Index: utils/mtgetfile ================================================================== --- /dev/null +++ utils/mtgetfile @@ -0,0 +1,31 @@ +#!/bin/bash + +fullparams="$@" + +function findfile () { +megatest $fullparams -repl < numargs 0)(car remargs) #f)) + (scriptn (if (> numargs 1)(cadr remargs) #f)) + (keys (cdb:remote-run db:get-keys #f)) + (target (if (args:get-arg "-reqtarg") + (args:get-arg "-reqtarg") + (if (args:get-arg "-target") + (args:get-arg "-target") + #f))) + (key-vals (if target (keys:target->keyval keys target) #f)) + (errmsg (cond + ((not key-vals) "missing -target") + ((not target) "missing -target") + ((not scriptn) "missing file name to find") + (else #f)))) + (if errmsg + (begin + (print "THEPATH: Missing required switch: " errmsg) + (print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]") + (exit))) + (print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn)) +EOF +} + +findfile | egrep "^THEPATH: " | sed -e 's/^THEPATH: //' ADDED utils/mtrunscript Index: utils/mtrunscript ================================================================== --- /dev/null +++ utils/mtrunscript @@ -0,0 +1,203 @@ +#!/usr/bin/env bash + +# Copyright 2012, Matthew Welland. +# +# This program is made available under the GNU GPL version 2.0 or +# greater. See the accompanying file COPYING for details. +# +# This program is distributed WITHOUT ANY WARRANTY; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +# PURPOSE. +# +# VERSION: + +# set -e +# set -u +# set -x + +# Usage: mtrunscript scriptname params +# +# Look for scriptname in this order +# +# $MT_TEST_RUN_DIR/scripts => $MT_RUN_AREA_HOME/scripts +# => $MT_RUN_AREA_HOME/../scripts => $PATH +# +# In each area look for the script with the name like this: +# +# scriptname_$TARGET[1]_$TARGET[2]_...$TARGET[n]_$MT_TESTNAME_$MT_ITEMPATH(s#/#_) +# + +echo "NOT IMPLEMENTED YET!" +exit + +case "x$1" in + # repo + xrep*) + fsl_dbinit + case "x$2" in + xhelp) + fsl_help + exit + ;; + + # repo get + xget) + hook_pre_repo_get "$@" + fsl_repo_get $3 $4 + hook_post_repo_get "$@" + exit + ;; + + xaddarea) + fsl_add_area $3 $4 + exit + ;; + + xdroparea) + fsl_remove_area $3 + exit + ;; + + xdbinit) + fsl_dbinit + exit + ;; + + xls|xlist) + shift + shift + fsl_ls "$@" + exit + ;; + + xcreate) + hook_pre_repo_create + fsl_repo_create $3 $4 $5 $6 + hook_post_repo_create + exit + ;; + + ximport) + fsl_repo_import $3 $4 $5 + exit + ;; + + *) + fsl_help + exit + esac + ;; + + "xmv") + if [ "x$2" = "x-f" ];then + # echo "Force mode" + fsl_force=1 + shift + shift + # change this to exec when happy! + # fsl mv -f f1 [f2 f3...] targ + fsl_mv "$@" + # args=("$@") + # echo $@ -> echo $@ + # use $# variable to print out + # number of arguments passed to the bash script + # echo Number of arguments passed: $# -> echo Number of arguments passed: $# + exit + else + # echo No force + shift + fsl_mv "$@" + exit + fi + ;; + + xtim*) + fsl_fork_find + shift + $FOSSILEXE timeline "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # leaves output needs to be niceified, no need for a function + xle*) + fsl_fork_find + shift + $FOSSILEXE leaves "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # changes and status + xcha* | xstat*) + fsl_fork_find + fsl_conflicts "$@" + rm -f $CONFLICT_FLAG_FILE + exit + ;; + + # ci/commit + xci | xcom*) + fsl_conflicts changes "$@" + trap "$FOSSILUTIL releaselock $FSLUTIL_PARAMS" SIGINT + # Set up for remote locking + if [ ! -e $CONFLICT_FLAG_FILE ]; then + rm -f $CONFLICT_FLAG_FILE + read -p "ERROR: Conflicts detected. Type \"yes\" to continue: " -e ANSWER + if [ $ANSWER = "yes" ]; then + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + else + exit 1 + fi + else + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + fi + exit + ;; + + xtag) + case "x$2" in + xadd | xcancel) + $FOSSILEXE "$@" + $FOSSILEXE sync + exit + ;; + + *) + $FOSSILEXE "$@" + exit + ;; + esac + ;; + + # add mention of repo to help + "xhelp") + if [ $# -gt 1 ]; then + case "x$2" in + xrepo) + fsl_help + exit + ;; + + *) + $FOSSILEXE "$@" + ;; + + esac + else + $FOSSILEXE help | sed -e 's/sync/sync repo/' + fi + exit + ;; + + xup* | xco) + fsl_fork_find + $FOSSILEXE "$@" + exit + ;; + +esac + +exec $FOSSILEXE "$@" Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -1,12 +1,76 @@ #!/bin/bash +############################################################################### +# +# nbfake - capture command output in a logfile +# +# nbfake behavior can be changed by setting the following env vars: +# NBFAKE_HOST SSH to $NBFAKE_HOST and run command +# NBFAKE_LOG Logfile for nbfake output +# +############################################################################### + +if [[ -z "$@" ]]; then + cat <<__EOF + +nbfake usage: + +nbfake + +nbfake behavior can be changed by setting the following env vars: + NBFAKE_HOST SSH to \$NBFAKE_HOST and run command + NBFAKE_LOG Logfile for nbfake output + +__EOF + exit +fi -# ssh localhost "nohup $* > nbfake.log 2> nbfake.err < /dev/null" +#============================================================================== +# Setup +#============================================================================== # Can't always trust $PWD -CURRWD=`pwd` +CURRWD=$(pwd) + +# Make sure nbfake host and logfile are set. Fall back to old-style variable names + +if [[ -z "$NBFAKE_HOST" && -n "$TARGETHOST" ]]; then + MY_NBFAKE_HOST=$TARGETHOST + unset TARGETHOST +else + MY_NBFAKE_HOST=$NBFAKE_HOST + unset NBFAKE_HOST +fi + + +if [[ -z "$NBFAKE_LOG" && -n "$TARGETHOST_LOGF" ]]; then + MY_NBFAKE_LOG=$TARGETHOST_LOGF + unset TARGETHOST_LOGF +else + MY_NBFAKE_LOG=$NBFAKE_LOG + unset NBFAKE_LOG +fi + +# Set default nbfake log + +if [[ -z "$MY_NBFAKE_LOG" ]]; then + MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T) +fi + +#============================================================================== +# Run and log +#============================================================================== + +cat <<__EOF >&2 +#====================================================================== +# NBFAKE logging command to: $MY_NBFAKE_LOG +# $* +#====================================================================== +__EOF -if [[ $TARGETHOST == "" ]]; then - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &" +if [[ -z "$MY_NBFAKE_HOST" ]]; then + # Run locally + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &" else - ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &\"" + # run remotely + ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi ADDED utils/plot-code.scm Index: utils/plot-code.scm ================================================================== --- /dev/null +++ utils/plot-code.scm @@ -0,0 +1,148 @@ +#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq + +(use regex srfi-69 srfi-13) + +(define targs #f) +(define files (cddddr (argv))) + +(let ((targdat (cadddr (argv)))) + (if (equal? targdat "-") + (set! targs files) + (set! targs (string-split targdat ",")))) + +(define filedat-defns (make-hash-table)) +(define filedat-usages (make-hash-table)) + +(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) +(define all-regexs (make-hash-table)) + +(define all-fns '()) + +(define (print-err . data) + (with-output-to-port (current-error-port) + (lambda () + (apply print data)))) + +(print-err "Making graph for files: " (string-intersperse targs ", ")) +(print-err "Looking at files: " (string-intersperse files ", ")) + +;; Gather the functions +;; +(for-each + (lambda (fname) + (print-err "Processing file " fname) + (with-input-from-file fname + (lambda () + (let loop ((inl (read-line))) + (if (not (eof-object? inl)) + (let ((match (string-match defn-rx inl))) + (if match + (let ((fnname (cadr match))) + ;; (print " " fnname) + (set! all-fns (cons fnname all-fns)) + (hash-table-set! + filedat-defns + fname + (cons fnname (hash-table-ref/default filedat-defns fname '()))) + )) + (loop (read-line)))))))) + files) + +;; fill up the regex hash +(print-err "Make the huge regex hash") +(for-each + (lambda (fnname) + (hash-table-set! all-regexs fnname (regexp (conc "^(|.*[^a-zA-Z]+)" fnname "([^a-zA-Z]+|)$")))) + (cons "toplevel" all-fns)) + +(define breadcrumbs (make-hash-table)) + +(define (have-function inl) + (let loop ((hed (car all-fns)) + (tal (cdr all-fns))) + (if (string-contains inl hed) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))) + +(define (look-for-all-calls inl fnname) + (if (have-function inl) ;; (string-search have-function-rx inl) + (let loop ((hed (car all-fns)) + (tal (cdr all-fns)) + (res '())) + (let ((match (string-match (hash-table-ref all-regexs hed) inl))) + (if match + (let ((newres (cons hed res))) + (if (null? tal) + newres + (loop (car tal) + (cdr tal) + newres))) + (if (null? tal) + res + (loop (car tal)(cdr tal) res))))) + '())) + +;; Gather the usages +(print "digraph G {") +(define curr-cluster-num 0) +(define function-calls '()) + +(for-each + (lambda (fname) + (let ((last-func #f)) + (print-err "Processing file " fname) + (print "subgraph cluster_" curr-cluster-num " {") + (set! curr-cluster-num (+ curr-cluster-num 1)) + (with-input-from-file fname + (lambda () + (with-output-to-port (current-error-port) + (lambda () + (print "Analyzing file " fname))) + (print "label=\"" fname "\";") + (let loop ((inl (read-line)) + (fnname "toplevel") + (allcalls '())) + (if (eof-object? inl) + (begin + (set! function-calls (cons (list fnname allcalls) function-calls)) + (for-each + (lambda (call-name) + (hash-table-set! breadcrumbs call-name #t)) + allcalls) + (print-err "function: " fnname " allcalls: " allcalls)) + (let ((match (string-match defn-rx inl))) + (if match + (let ((func-name (cadr match))) + (if last-func + (print "\"" func-name "\" -> \"" last-func "\";") + (print "\"" func-name "\";")) + (set! last-func func-name) + (hash-table-set! breadcrumbs func-name #t) + (loop (read-line) + func-name + allcalls)) + (let ((calls (look-for-all-calls inl fnname))) + (loop (read-line) fnname (append allcalls calls))))))))) + (print "}"))) + targs) + +(print-err "breadcrumbs: " (hash-table-keys breadcrumbs)) +(print-err "function-calls: " function-calls) + +(for-each + (lambda (function-call) + (print-err "function-call: " function-call) + (let ((fnname (car function-call)) + (calls (cadr function-call))) + (for-each + (lambda (callname) + (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ") + "\"" fnname "\" -> \"" callname "\";")) + calls))) + function-calls) + +(print "}") + +(exit) ADDED utils/revtagfsl.scm Index: utils/revtagfsl.scm ================================================================== --- /dev/null +++ utils/revtagfsl.scm @@ -0,0 +1,78 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use json regex posix) +(use srfi-69) + +;; Add tags with node nums: trunk(12) +(define fname #f) + +(let ((parms (argv))) + (if (> (length parms) 1) + (set! fname (cadr parms)))) + +(if (not (and fname (file-exists? fname))) + (begin + (print "Usage: revtagfsl /path/to/fossilfile.fossil") + (exit 1))) + +(define (revtag:get-timeline fslfname limit) + (let* ((cmd (if (file-exists? fslfname) + (conc "fossil json timeline checkin --limit " limit " -R " fslfname) + (conc "fossil json timeline checkin --limit " limit)))) + (with-input-from-pipe cmd json-read))) + + +(define mt (vector->list (revtag:get-timeline fname 10000))) +(define tl (map vector->list (cdr (assoc "timeline" (vector->list (cdr (assoc "payload" mt))))))) + +(define tagged (make-hash-table)) +(define usedtags (make-hash-table)) + +(for-each (lambda (node) + (let* ((uuid (cdr (assoc "uuid" node))) + (tags-dat (assoc "tags" node)) + (tags (if tags-dat (cdr tags-dat) '()))) + (for-each (lambda (tag) + (hash-table-set! usedtags tag #t)) + tags))) + tl) + +(define ord-tl (sort tl (lambda (a b)(let ((ta (cdr (assoc "timestamp" a)))(tb (cdr (assoc "timestamp" b))))(< ta tb))))) + +(define (make-tag branch) + (let* ((nextnum (+ 1 (hash-table-ref/default tagged branch 0)))) + (hash-table-set! tagged branch nextnum) + (conc branch "-r" nextnum))) + +(define (get-next-revtag branch) + (let loop ((tag (make-tag branch))) + (if (hash-table-ref/default usedtags tag #f) + (loop (make-tag branch)) + tag))) + +(print "branch, uuid, newtag") + +(let loop ((hed (car ord-tl)) + (tal (cdr ord-tl))) + (let* ((tags (let ((t (assoc "tags" hed))) + (if t (cdr t) '()))) + (uuid (cdr (assoc "uuid" hed))) + (branch (if (null? tags) "nobranch" (car tags))) + (tagpatt (regexp (conc "^" branch "-r\\d+$"))) + (currtag (filter (lambda (x)(string-match tagpatt x)) tags))) + (if (and (not (equal? branch "nobranch")) + (null? currtag)) + (let ((newtag (get-next-revtag branch))) + (print branch ", " uuid ", " newtag) + (system (conc "fossil tag add \"" newtag "\" " uuid " -R " fname)) ;; ?--raw? ?--propagate? TAGNAME CHECK-IN ?VALUE? + (hash-table-set! usedtags currtag #t))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))))) ADDED widgets.scm Index: widgets.scm ================================================================== --- /dev/null +++ widgets.scm @@ -0,0 +1,189 @@ +(require-library srfi-4 iup) +(import srfi-4 iup iup-pplot iup-glcanvas) ;; iup-web + +(define (popup dlg . args) + (apply show dlg #:modal? 'yes args) + (destroy! dlg)) + +(define (properties ih) + (popup (element-properties-dialog ih)) + 'default) + +(define dlg + (dialog + (vbox + (hbox ; headline + (fill) + (frame (label " Inspect control and dialog classes " + fontsize: 15)) + (fill) + margin: '0x0) + + (label "") + (label "Dialogs" fontsize: 12) + (hbox + (button "dialog" + action: (lambda (self) (properties (dialog (vbox))))) + (button "color-dialog" + action: (lambda (self) (properties (color-dialog)))) + (button "file-dialog" + action: (lambda (self) (properties (file-dialog)))) + (button "font-dialog" + action: (lambda (self) (properties (font-dialog)))) + (button "message-dialog" + action: (lambda (self) (properties (message-dialog)))) + (fill) + margin: '0x0) + (hbox + (button "layout-dialog" + action: (lambda (self) (properties (layout-dialog)))) + (button "element-properties-dialog" + action: (lambda (self) + (properties + (element-properties-dialog (create 'user))))) + (fill) + margin: '0x0) + + (label "") + (label "Composition widgets" fontsize: 12) + (hbox + (button "fill" + action: (lambda (self) (properties (fill)))) + (button "hbox" + action: (lambda (self) (properties (hbox)))) + (button "vbox" + action: (lambda (self) (properties (vbox)))) + (button "zbox" + action: (lambda (self) (properties (zbox)))) + (button "radio" + action: (lambda (self) (properties (radio (vbox))))) + (button "normalizer" + action: (lambda (self) (properties (normalizer)))) + (button "cbox" + action: (lambda (self) (properties (cbox)))) + (button "sbox" + action: (lambda (self) (properties (sbox (vbox))))) + (button "split" + action: (lambda (self) (properties (split (vbox) (vbox))))) + (fill) + margin: '0x0) + + (label "") + (label "Standard widgets" fontsize: 12) + (hbox + (button "button" + action: (lambda (self) (properties (button)))) + (button "canvas" + action: (lambda (self) (properties (canvas)))) + (button "frame" + action: (lambda (self) (properties (frame)))) + (button "label" + action: (lambda (self) (properties (label)))) + (button "listbox" + action: (lambda (self) (properties (listbox)))) + (button "progress-bar" + action: (lambda (self) (properties (progress-bar)))) + (button "spin" + action: (lambda (self) (properties (spin)))) + (fill) + margin: '0x0) + (hbox + (button "tabs" + action: (lambda (self) (properties (tabs)))) + (button "textbox" + action: (lambda (self) (properties (textbox)))) + (button "toggle" + action: (lambda (self) (properties (toggle)))) + (button "treebox" + action: (lambda (self) (properties (treebox)))) + (button "valuator" + action: (lambda (self) (properties (valuator "")))) + (fill) + margin: '0x0) + + (label "") + (label "Additional widgets" fontsize: 12) + (hbox + (button "cells" + action: (lambda (self) (properties (cells)))) + (button "color-bar" + action: (lambda (self) (properties (color-bar)))) + (button "color-browser" + action: (lambda (self) (properties (color-browser)))) + (button "dial" + action: (lambda (self) (properties (dial "")))) + (button "matrix" + action: (lambda (self) (properties (matrix)))) + (fill) + margin: '0x0) + (hbox + (button "pplot" + action: (lambda (self) (properties (pplot)))) + (button "glcanvas" + action: (lambda (self) (properties (glcanvas)))) + ;; (button "web-browser" + ;; action: (lambda (self) (properties (web-browser)))) + (fill) + margin: '0x0) + + (label "") + (label "Menu widgets" fontsize: 12) + (hbox + (button "menu" + action: (lambda (self) (properties (menu)))) + (button "menu-item" + action: (lambda (self) (properties (menu-item)))) + (button "menu-separator" + action: (lambda (self) (properties (menu-separator)))) + (fill) + margin: '0x0) + + (label "") + (label "Images" fontsize: 12) + (hbox + (button "image/palette" + action: (lambda (self) + (properties + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgb" + action: (lambda (self) + (properties + (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgba" + action: (lambda (self) + (properties + (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/file" + action: (lambda (self) + (properties + ;; same attributes as image/palette + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + ;; needs a file in current directory + ;(image/file "chicken.ico")))) ; ok + ;(image/file "chicken.png")))) ; doesn't work + (fill) + margin: '0x0) + + (label "") + (label "Other widgets" fontsize: 12) + (hbox + (button "clipboard" + action: (lambda (self) (properties (clipboard)))) + (button "timer" + action: (lambda (self) (properties (timer)))) + (button "spinbox" + action: (lambda (self) (properties (spinbox (vbox))))) + (fill) + margin: '0x0) + + (fill) + (button "E&xit" + expand: 'horizontal + action: (lambda (self) 'close)) + ) + margin: '15x15 + title: "Iup inspector")) + +(show dlg) +(main-loop) +(exit 0) DELETED zmq-transport.scm Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ /dev/null @@ -1,493 +0,0 @@ - -;; Copyright 2006-2012, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use zmq) - -(declare (unit zmq-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses server)) - -(include "common_records.scm") -(include "db_records.scm") - -;; Transition to pub --> sub with pull <-- push -;; -;; 1. client sends request to server via push to the pull port -;; 2. server puts request in queue or processes immediately as appropriate -;; 3. server puts responses from completed requests into pub port -;; -;; TODO -;; -;; Done Tested -;; [x] [ ] 1. Add columns pullport pubport to servers table -;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 -;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports -;; [x] [ ] 4. Add client compose of request -;; [x] [ ] - name of client: testname/itempath-test_id-hostname -;; [x] [ ] - name of request: callname, params -;; [x] [ ] - request key: f(clientname, callname, params) -;; [x] [ ] 5. Add processing of subscription hits -;; [x] [ ] - done when get key -;; [x] [ ] - return results -;; [x] [ ] 6. Add timeout processing -;; [x] [ ] - after 60 seconds -;; [ ] [ ] i. check server alive, connect to new if necessary -;; [ ] [ ] ii. resend request -;; [ ] [ ] 7. Turn self ping back on - -(define (zmq-transport:make-server-url hostport) - (if (not hostport) - #f - (conc "tcp://" (car hostport) ":" (cadr hostport)))) - -(define *server-loop-heart-beat* (current-seconds)) -(define *heartbeat-mutex* (make-mutex)) - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -(define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) -(define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) -(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) -(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) - -(define (zmq-transport:run hostn) - (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") - (exit)))) - (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db - (zmq-sdat1 #f) - (zmq-sdat2 #f) - (pull-socket #f) - (pub-socket #f) - (p1 #f) - (p2 #f) - (zmq-sockets-dat #f) - (iface (if (string=? "-" hostn) - "*" ;; (get-host-name) - hostn)) - (hostname (get-host-name)) - (ipaddrstr (let ((ipstr (if (string=? "-" hostn) - (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f))) - (if ipstr ipstr hostname))) - (last-run 0)) - (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port") - (string->number (args:get-arg "-port")) - (+ 5000 (random 1001))))) - - (set! zmq-sdat1 (car zmq-sockets-dat)) - (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port) - (set! p1 (caddr zmq-sdat1)) - - (set! zmq-sdat2 (cadr zmq-sockets-dat)) - (set! pub-socket (cadr zmq-sdat2)) - (set! p2 (caddr zmq-sdat2)) - - (set! *cache-on* #t) - - (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? - - ;; what to do when we quit - ;; -;; (on-exit (lambda () -;; (if (and *toppath* *server-info*) -;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) -;; (let loop () -;; (let ((queue-len 0)) -;; (thread-sleep! (random 5)) -;; (mutex-lock! *incoming-mutex*) -;; (set! queue-len (length *incoming-data*)) -;; (mutex-unlock! *incoming-mutex*) -;; (if (> queue-len 0) -;; (begin -;; (debug:print-info 0 "Queue not flushed, waiting ...") -;; (loop)))))))) - - ;; The heavy lifting - ;; - ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime - ;; - (debug:print-info 11 "Server setup complete, start listening for messages") - (let loop ((queue-lst '())) - (let* ((rawmsg (receive-message* pull-socket)) - (packet (db:string->obj rawmsg)) - (qtype (cdb:packet-get-qtype packet))) - (debug:print-info 12 "server=> received packet=" packet) - (if (not (member qtype '(sync ping))) - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*))) - (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue - (begin - (db:process-queue-item db packet) - ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) - - (loop '())) - (loop (cons packet queue-lst))))))) - -;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being -;; used and to shutdown after sometime if it is not. -;; -(define (zmq-transport:keep-running) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - ;; This thread waits for the server to come alive - (let* ((server-info (let loop () - (let ((sdat #f)) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *server-info*) - (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat - (begin - (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again") - (sleep 4) - (loop)))))) - (iface (cadr server-info)) - (pullport (caddr server-info)) - (pubport (cadddr server-info)) ;; id interface pullport pubport) - ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport)) - (last-access 0)) - (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - ;; GET REAL QUEUE LENGTH FROM THE VARIABLE - (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info)) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - (if (> (+ last-access - ;; (* 50 60 60) ;; 48 hrs - ;; 60 ;; one minute - ;; (* 60 60) ;; one hour - (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. - ) - (current-seconds)) - (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) - -(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50)) - (let ((s (if s s (make-socket stype))) - (p (if (number? port) port 5555)) - (old-handler (current-exception-handler))) - (handle-exceptions - exn - (begin - (debug:print 0 "Failed to bind to port " p ", trying next port") - (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) - ;; (old-handler) - ;; (print-call-chain) - (if (> trynum 0) - (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1)) - (debug:print-info 0 "Tried ports up to " p - " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")) - (exit)) ;; To exit or not? That is the question. - (let ((zmq-url (conc "tcp://" iface ":" p))) - (debug:print 2 "Trying to start server on " zmq-url) - (bind-socket s zmq-url) - (list iface s port))))) - -(define (zmq-transport:setup-ports ipaddrstr startport) - (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull)) - (p1 (caddr s1)) - (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub)) - (p2 (caddr s2))) - (set! *runremote* #f) - (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2) - (mutex-lock! *heartbeat-mutex*) - (set! *server-info* (open-run-close tasks:server-register - tasks:open-db - (current-process-id) - ipaddrstr p1 - 0 - 'live - 'zmq - pubport: p2)) - (debug:print-info 11 "*server-info* set to " *server-info*) - (mutex-unlock! *heartbeat-mutex*) - (list s1 s2))) - -(define (zmq-transport:mk-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (list (current-directory) - (argv))))))) - -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -;; -(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '())) - (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions) - (let ((connect-ok #f) - (zmq-socket (if context - (make-socket type context) - (make-socket type))) - (conurl (zmq-transport:make-server-url (list iface port)))) - (if (socket? zmq-socket) - (begin - ;; first apply subscriptions - (for-each (lambda (subscription) - (debug:print 2 "Subscribing to " subscription) - (socket-option-set! zmq-socket 'subscribe subscription)) - subscriptions) - (connect-socket zmq-socket conurl) - zmq-socket) - (begin - (debug:print 0 "ERROR: Failed to open socket to " conurl) - #f)))) - -(define (zmq-transport:client-connect iface pullport pubport) - (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push)) - (sub-socket (zmq-transport:client-socket-connect iface pubport - type: 'sub - subscriptions: (list (client:get-signature) "all"))) - (zmq-sockets (vector push-socket sub-socket)) - (login-res #f)) - (debug:print-info 11 "zmq-transport:client-connect started. Next is login") - (set! login-res (client:login serverdat zmq-sockets)) - (if (and (not (null? login-res)) - (car login-res)) - (begin - (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".") - (set! *runremote* zmq-sockets) - zmq-sockets) - (begin - (debug:print-info 2 "Failed to login or connect to " conurl) - (set! *runremote* #f) - #f)))) - -;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being -;; used and to shutdown after sometime if it is not. -;; -(define (zmq-transport:keep-running) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - ;; This thread waits for the server to come alive - (let* ((server-info (let loop () - (let ((sdat #f)) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) - (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat - (begin - (sleep 4) - (loop)))))) - (iface (car server-info)) - (port (cadr server-info)) - (last-access 0) - (tdb (tasks:open-db)) - (spid (tasks:server-get-server-id tdb #f iface port #f))) - (print "Keep-running got server pid " spid ", using iface " iface " and port " port) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - (tasks:server-update-heartbeat tdb spid) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - (if (> (+ last-access - ;; (* 50 60 60) ;; 48 hrs - ;; 60 ;; one minute - ;; (* 60 60) ;; one hour - (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. - ) - (current-seconds)) - (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (tasks:server-deregister-self tdb (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) - -;; all routes though here end in exit ... -(define (zmq-transport:launch) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting zmq server") - (if *toppath* - (let* (;; (th1 (make-thread (lambda () - ;; (let ((server-info #f)) - ;; ;; wait for the server to be online and available - ;; (let loop () - ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat") - ;; (thread-sleep! 2) - ;; (mutex-lock! *heartbeat-mutex*) - ;; (set! server-info *server-info* ) - ;; (mutex-unlock! *heartbeat-mutex*) - ;; (if (not server-info)(loop))) - ;; (debug:print 2 "Server alive, starting self-ping") - ;; (zmq-transport:self-ping server-info) - ;; )) - ;; "Self ping")) - (th2 (make-thread (lambda () - (zmq-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-"))) "Server run")) - ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) - ) - (set! *client-non-blocking-mode* #t) - ;; (thread-start! th1) - (thread-start! th2) - ;; (thread-start! th3) - (set! *didsomething* #t) - ;; (thread-join! th3) - (thread-join! th2) - ) - (debug:print 0 "ERROR: Failed to setup for megatest"))) - -(define (zmq-transport:client-signal-handler signum) - (handle-exceptions - exn - (debug:print " ... exiting ...") - (let ((th1 (make-thread (lambda () - (if (not *received-response*) - (receive-message* *runremote*))) ;; flush out last call if applicable - "eat response")) - (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") - (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 " Done.") - (exit 4)) - "exit on ^C timer"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2)))) - -(define (zmq-transport:client-launch) - (set-signal-handler! signal/int zmq-transport:client-signal-handler) - (if (zmq-transport:client-setup) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) - -;;====================================================================== -;; Defunct functions -;;====================================================================== - -;; ping a server and return number of clients or #f (if no response) -;; NOT IN USE! -(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f)) - (cdb:use-non-blocking-mode - (lambda () - (let* ((res #f) - (th1 (make-thread - (lambda () - (let* ((zmq-context (make-context 1)) - (zmq-socket (zmq-transport:client-connect host port context: zmq-context))) - (if zmq-socket - (if (zmq-transport:client-login zmq-socket) - (let ((numclients (cdb:num-clients zmq-socket))) - (if (not return-socket) - (begin - (zmq-transport:client-logout zmq-socket) - (close-socket zmq-socket))) - (set! res (list #t numclients (if return-socket zmq-socket #f)))) - (begin - ;; (close-socket zmq-socket) - (set! res (list #f "CAN'T LOGIN" #f)))) - (set! res (list #f "CAN'T CONNECT" #f))))) - "Ping: th1")) - (th2 (make-thread - (lambda () - (let loop ((count 1)) - (debug:print-info 1 "Ping " count " server on " host " at port " port) - (thread-sleep! 2) - (if (< count (/ secs 2)) - (loop (+ count 1)))) - ;; (thread-terminate! th1) - (set! res (list #f "TIMED OUT" #f))) - "Ping: th2"))) - (thread-start! th2) - (thread-start! th1) - (handle-exceptions - exn - (set! res (list #f "TIMED OUT" #f)) - (thread-join! th1 secs)) - res)))) - -;; (define (zmq-transport:self-ping server-info) -;; ;; server-info: server-id interface pullport pubport -;; (let ((iface (list-ref server-info 1)) -;; (pullport (list-ref server-info 2)) -;; (pubport (list-ref server-info 3))) -;; (zmq-transport:client-connect iface pullport pubport) -;; (let loop () -;; (thread-sleep! 2) -;; (cdb:client-call *runremote* 'ping #t) -;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!") -;; (mutex-lock! *heartbeat-mutex*) -;; (set! *server-loop-heart-beat* (current-seconds)) -;; (mutex-unlock! *heartbeat-mutex*) -;; (loop)))) - -(define (zmq-transport:reply pubsock target query-sig success/fail result) - (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result) - (send-message pubsock target send-more: #t) - (send-message pubsock (db:obj->string (vector success/fail query-sig result)))) -