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 area-dat 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 area-dat) (db:open-rundb dbstruct area-dat run-id) ))) - ;; db prunning would go here - (mutex-unlock! *rundb-mutex*) dbdat)))) (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) @@ -141,29 +138,26 @@ ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id area-dat) - (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) + (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") (configdat (megatest:area-configdat area-dat)) (toppath (megatest:area-path area-dat)) (link-tree-path (configf:lookup configdat "setup" "linktree")) (dbpath (configf:lookup configdat "setup" "dbdir")) (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 area-dat) (let ((syncprag (configf:lookup (megatest:area-configdat area-dat) "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) @@ -201,85 +195,94 @@ (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 area-dat)) ;; (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) + (begin + (mutex-lock! *rundb-mutex*) + (let* ((dbpath (db:dbfile-path run-id area-dat)) ;; (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 area-dat 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)) + (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)) )) area-dat)) ;; add strings db to rundb, not in use yet - ;; )) ;; (sqlite3:open-database dbpath)) - (olddb (if *megatest-db* - *megatest-db* + ;; )) ;; (sqlite3:open-database dbpath)) + (olddb (if *megatest-db* + *megatest-db* (let ((db (db:open-megatest-db area-dat))) - (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 + (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 area-dat db:sync-tests-only db inmem) (db:delay-if-busy refdb area-dat) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) + (dbr:dbstruct-set-refdb! dbstruct refdb) (db:sync-tables area-dat 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)))))) + ;; 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 area-dat) ;; (conc toppath "/megatest.db") (car configinfo))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb - (let* ((dbpath (db:dbfile-path 0 area-dat)) - (dbexists (file-exists? dbpath)) + (begin + (mutex-lock! *rundb-mutex*) + (let* ((dbpath (db:dbfile-path 0 area-dat)) + (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db area-dat)) area-dat)) (olddb (db:open-megatest-db area-dat)) - (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)))) + (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 area-dat #!key (local #f)) (let* ((dbdir (db:dbfile-path #f area-dat)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) 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 @@ -837,11 +837,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 area-dat)) (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 @@ -907,11 +907,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"))) @@ -1278,11 +1277,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") @@ -1375,11 +1374,11 @@ (keys #f)) (if (not (launch:setup-for-run *area-dat*)) (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") @@ -1472,10 +1471,11 @@ ;; (import csi) (import readline) (use-legacy-bindings) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + (include "readline-fix.scm") (gnu-history-install-file-manager (let ((d (string-append (or (get-environment-variable "HOME") ".") "/.megatest"))) (if (not (file-exists? d)) (create-directory d #t)) 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 area-dat) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)) (configdat (megatest:area-configdat area-dat))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -901,11 +901,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* ((configdat (megatest:area-configdat area-dat)) (toppath (megatest:area-path area-dat)) (run-info (rmt:get-run-info run-id area-dat)) (tests-info (mt:get-tests-for-run run-id #f '() '() area-dat)) ;; qryvals: "id,testname,item_path")) @@ -1600,11 +1600,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 area-dat) (rmt:delete-old-deleted-test-records area-dat) - ;; (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)))) @@ -1686,12 +1686,10 @@ (if (launch:setup-for-run area-dat) (launch:cache-config area-dat) (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))) @@ -1806,11 +1804,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 area-dat proc synckey keynum synchash run-id . params) (let* ((data (rmt:synchash-get run-id proc synckey keynum params area-dat)) (newdat (car data)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -53,15 +53,21 @@ (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path area-dat) - (let* ((linktree (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree")) - (dbpath (conc linktree "/.db"))) - dbpath)) - - + (let* ((configdat (megatest:area-configdat area-dat)) + (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/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -29,5 +29,8 @@ [jobtools] # launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk # launcher nbfake # maxload 4 + +launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log + Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,9 +1,11 @@ [setup] 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 +# All these are overridden in ../fdk.config +# [jobtools] +# launcher nbfake +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log [include ../fdk.config] Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -21,19 +21,25 @@ [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] + +# turn off faststart, put monitor.db in MT_RUN_AREA_HOME/db +# and set the dbdir to /var/tmp/$USER/mt_db to enable keeping +# the raw db in /var/tmp/$USER +# +faststart no +monitordir #{getenv MT_RUN_AREA_HOME}/db +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,8 +213,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 (if (equal? (getenv "datapath") "none") "nbfake" "sleeprunner")} +# [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 +