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