Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -36,11 +36,11 @@ ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard -mtest: $(OFILES) megatest.o +mtest: $(OFILES) megatest.o readline-fix.scm csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard @@ -192,5 +192,12 @@ mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) +# "(define (toplevel-command . a) #f)" +readline-fix.scm : + if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + echo "(use-legacy-bindings)" > readline-fix.scm; \ + else \ + echo "" > readline-fix.scm;\ + fi Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -85,16 +85,20 @@ (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) - (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))) + (handle-exceptions + exn + (debug:print 0 "ERROR: failed to process config input \"" l "\"") + (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) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -61,18 +61,15 @@ ;; (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) @@ -141,27 +138,23 @@ ;; NB// #f => return dbdir only ;; (was planned to be; 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")) - (dbpath (configf:lookup *configdat* "setup" "dbdir")) + (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") + (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) - #f)) - (dbdir (if dbpath - dbpath - (conc link-tree-path "/.db/")))) + #f))) (handle-exceptions exn (begin (debug:print 0 "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname - (conc dbdir fname) + (conc dbdir "/" fname) dbdir))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) @@ -199,81 +192,90 @@ (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) - ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders - ;; (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)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db - ;; sync once more to deal with delays? - ;; (db:sync-tables db:sync-tests-only db inmem) - ;; (db:sync-tables db:sync-tests-only inmem refdb) - inmem)))))) + (begin + (mutex-lock! *rundb-mutex*) + (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) + (mutex-unlock! *rundb-mutex*) + (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) + ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders + ;; (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)) ;; What does delaying here achieve? + (dbr:dbstruct-set-refdb! dbstruct refdb) + (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db + ;; sync once more to deal with delays? + ;; (db:sync-tables db:sync-tests-only db inmem) + ;; (db:sync-tables db:sync-tests-only inmem 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)))) + (begin + (mutex-lock! *rundb-mutex*) + (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) + (mutex-unlock! *rundb-mutex*) + (if (and (not dbexists) + *db-write-access*) ;; did not have a prior db and do have write access + (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically + 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 (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -36,11 +36,11 @@ ;; ;; 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 *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)) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -16,29 +16,10 @@ (declare (unit items)) (declare (uses common)) (include "common_records.scm") -;; Puts out all combinations -(define (process-itemlist hierdepth curritemkey itemlist) - (let ((res '())) - (if (not hierdepth) - (set! hierdepth (length itemlist))) - (let loop ((hed (car itemlist)) - (tal (cdr itemlist))) - (if (null? tal) - (for-each (lambda (item) - (if (> (length curritemkey) (- hierdepth 2)) - (set! res (append res (list (append curritemkey (list (list (car hed) item)))))))) - (cadr hed)) - (begin - (for-each (lambda (item) - (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal)))) - (cadr hed)) - (loop (car tal)(cdr tal))))) - res)) - ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -825,11 +825,10 @@ (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) - ;; (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) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -7,10 +7,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") + +(define (toplevel-command . a) #f) (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed @@ -888,11 +890,10 @@ "%")) (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)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table)) (dmode (let ((d (args:get-arg "-dumpmode"))) @@ -1250,11 +1251,11 @@ ;; 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 + ;; DO NOT put this one into either rmt: or open-run-close (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") @@ -1347,11 +1348,11 @@ (keys #f)) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! keys (cdb:remote-run db:get-keys db)) + (set! keys (rmt: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") @@ -1430,11 +1431,10 @@ ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline -(define (toplevel-command . a) #f) (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) @@ -1445,10 +1445,11 @@ (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + (include "readline-fix.scm") (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") Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -184,11 +184,11 @@ (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))) + (let ((test-id (rmt:get-test-id 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 Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -895,11 +895,11 @@ ;; 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) + ;; (rmt:find-and-mark-incomplete) (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)) @@ -1591,11 +1591,11 @@ (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) - ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) + ;; (rmt:set-var "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)))) @@ -1674,12 +1674,10 @@ (if (launch:setup-for-run) (launch:cache-config) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - ;; (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))) @@ -1794,11 +1792,11 @@ new-run-id (cddr (vector->list testdat))) (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)) - (cdb:remote-run + (cdb:remote-run ;; to be replaced, note: this routine is not used currently (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=?;") Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -56,14 +56,10 @@ orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) -;; (cdb:remote-run db:get-keys #f) -;; (cdb:remote-run db:get-num-runs #f "%") -;; (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 run-id . params) (let* ((data (rmt:synchash-get run-id proc synckey keynum params)) (newdat (car data)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -53,15 +53,20 @@ (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)) - - + (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") + (configf:lookup *configdat* "setup" "dbdir") + (conc (configf:lookup *configdat* "setup" "linktree") "/.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))) + dbdir)) ;; If file exists AND ;; file readable ;; ==> open it ;; If file exists AND Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -21,19 +21,23 @@ [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] + +# put monitor.db in MT_RUN_AREA_HOME/db +monitordir #{getenv MT_RUN_AREA_HOME}/db + +# set the dbdir to /var/tmp/$USER/mt_db, default is linktree +dbdir /var/tmp/#{getenv USER}/mt_db + # 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 -# set the dbdir, default is linktree -dbdir #{getenv MT_RUN_AREA_HOME}/db/ - # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. @@ -207,14 +211,14 @@ # Within the archive the data is structured like this: # /// disk0 /tmp/#{getenv USER}/adisk1 # Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) -[jobtools] -launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ - ((none) "nbfake") \ - ((openlava) "bsub") \ - (else "sleeprunner"))} - -launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log +# [jobtools] +# launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ +# ((none) "nbfake") \ +# ((openlava) "bsub") \ +# (else "sleeprunner"))} +# +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log