Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -29,13 +29,18 @@ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm pgdb.scm # cgisetup/models/pgdb.scm +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt + # module source files MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \ ducttape-lib.scm pkts.scm dbi.scm autoload.scm stml2.scm +# dbmod.import.o is just a hack here +mofiles/dbfile.o : mofiles/debugprint.o dbmod.import.o +mofiles/debugprint.o : mofiles/mtargs.o # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm @@ -91,12 +96,10 @@ ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest showmtesthash: @@ -168,11 +171,12 @@ mofiles/dbi.o : mofiles/autoload.o mofiles/pkts.o : mofiles/dbi.o mofiles/dbfile.o : mofiles/debugprint.o mofiles/debugprint.o : mofiles/mtargs.o -common.o : mofiles/commonmod.o megatest-fossil-hash.scm +mofiles/commonmod.o : megatest-fossil-hash.scm +common.o : mofiles/commonmod.o # mofiles/dbmod.o : mofiles/configfmod.o # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -442,23 +442,18 @@ ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) - (debug:print 0 *default-log-port* "WARNING: common:cleanup-db has NOT been reimplemented yet! Please fix!") - #;(apply db:multi-db-sync + (apply db:multi-db-sync dbstruct 'schema - ;; 'new2old 'killservers 'adj-target - ;; 'old2new 'new2old - ;; (if full - '(dejunk) - ;; '()) - ) + '(dejunk) + ) (if (common:api-changed?) (common:set-last-run-version))) (define (common:snapshot-file filepath #!key (subdir ".") ) (if (file-exists? filepath) @@ -949,10 +944,22 @@ (begin (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) + + +(define (common:db-tmp-area-path) + (conc "/tmp/" + (current-user-name) + "/megatest_localdb/" + (common:get-testsuite-name) + "/" + (string-translate *toppath* "/" ".") + ) +) + ;;====================================================================== ;; redefine for future cleanup (converge on area-name, the more generic ;; (define common:get-area-name common:get-testsuite-name) @@ -2518,17 +2525,10 @@ ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== -(define (bb-check-path #!key (msg "check-path: ")) - (let ((path (or (get-environment-variable "PATH") "none"))) - (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) - (if (string-match "^.*/isoenv-core/.*" path) - (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod - (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) - (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME"))) ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]")) (mungeval (lambda (val) @@ -2539,13 +2539,16 @@ (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) - (delim (if (string-search whitesp val) + (delim (if (and (string-search whitesp val) + (not (string-search "^\".*\"$" val)) + (not (string-search "^'.*'$" val))) "\"" ""))) + (print (if (or (member key ignorevars) (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) @@ -2553,11 +2556,13 @@ (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) - (delim (if (string-search whitesp val) + (delim (if (and (string-search whitesp val) + (not (string-search "^\".*\"$" val)) + (not (string-search "^'.*'$" val))) "\"" ""))) (print (if (or (member key ignorevars) (string-search whitesp key) (string-search ":" key)) ;; internal only values to be skipped. Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -41,17 +41,15 @@ (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) -(declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) -;; (declare (uses dashboard-main)) (declare (uses mt)) (declare (uses dbfile)) (include "common_records.scm") (include "db_records.scm") @@ -62,107 +60,47 @@ (include "vg_records.scm") (dbfile:db-init-proc db:initialize-main-db) (define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2017 + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version + " license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help - -test run-id,test-id : control test identified by testid + -test run-id test-id : open a test control panel on this test -skip-version-check : skip the version check - -use-db-cache : access database via cache - -Misc -rows R : set number of rows -cols C : set number of columns -")) + -start-dir dir : start dashboard in the given directory + -target target : filter runs tab to given target. + -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 + -repl : Start a chicken scheme interpreter +" +)) -;; -server host:port : connect to host:port instead of db access -;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id -;; -guimonitor : control panel for runs ;; process args (define remargs (args:get-args (argv) + ;; parameters (need arguments) (list "-rows" "-cols" - "-run" - "-test" - "-xterm" - "-debug" - "-host" - "-transport" - "-start-dir" - ) - (list "-h" - "-use-server" - "-guimonitor" - "-main" - "-v" - "-q" - "-use-db-cache" + "-test" ;; given a run id and test id, open only a test control panel on that test.. + "-debug" + "-start-dir" + "-target" + ) + ;; switches (don't take arguments) + (list "-h" "-skip-version-check" "-repl" - "-rh5.11" ;; fix to allow running on rh5.11 "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) -;; check for MT_* environment variables and exit if found -(if (not (args:get-arg "-test")) - (begin - (display "Checking for MT_ vars: ") - (for-each (lambda (var) - (display " ")(display var) - (if (get-environment-variable var) - (begin - (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") - (exit 1)))) - '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - (print ". Done. All ok."))) - -(if (not (null? remargs)) - (begin - (print "Unrecognised arguments: " (string-intersperse remargs " ")) - (exit))) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - -(if (args:get-arg "-start-dir") - (if (directory-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - -;; TODO: Move this inside (main) -;; -(if (not (launch:setup)) - (begin - (print "Failed to find megatest.config, exiting") - (exit 1))) - -;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature -;; first check for the switch -;; -(if (or (args:get-arg "-rh5.11") - (configf:lookup *configdat* "dashboard" "no-detachbox") - (not (file-exists? "/etc/os-release"))) - (set! iup:detachbox iup:vbox)) - -(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) @@ -185,10 +123,11 @@ update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs + target ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 @@ -196,10 +135,11 @@ please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f + target: "" )) ;;====================================================================== ;; buttons color using image ;;====================================================================== @@ -267,19 +207,20 @@ tabdat)) ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) + (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list (lambda (updater) - ;; (debug:print 3 *default-log-port* "Running " updater) + ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; adds the updater passed in the updaters list at that hashkey @@ -435,14 +376,14 @@ (define (dboard:setup-tabdat tabdat) (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) + ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) @@ -480,11 +421,11 @@ hierdat ;; put hierarchial sorted list here tests ;; hash of id => testdat ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals ((last-update 0) : number) ;; last query to db got records from before last-update - ((last-db-time 0) : number) ;; last timestamp on megatest.db + ((last-db-time 0) : number) ;; last timestamp on main.db ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items (db-path #f)) ;; for the new runs view lets build up a few new record types and then consolidate later @@ -726,11 +667,11 @@ (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (common:get-db-tmp-area)) - (db-pth (conc db-dir "/megatest.db"))) + (db-pth (conc db-dir "/.megatest/main.db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress @@ -757,11 +698,11 @@ ) ;; if we saw the db modified, reset it (the signal has already been used) (if (and got-all ;; (not multi-get) db-modified) - (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the ;; data has been read ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above @@ -1678,11 +1619,11 @@ ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" - #:size "10x" + ;; #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) @@ -2003,11 +1944,11 @@ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) @@ -2790,11 +2731,12 @@ (dboard:runs-tree-new-browser commondat rdat) (dboard:runs-new-matrix commondat rdat) ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (let* ((stats-dat (dboard:tabdat-make-data)) + (let* ( + (stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) @@ -2816,11 +2758,13 @@ (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat)) (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes"))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) - + + + ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -2976,14 +2920,14 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 100 + #:value 250 (dboard:runs-tree-browser commondat runs-dat) (iup:split - #:value 100 + #:value 200 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox #:expand "YES" @@ -3034,20 +2978,22 @@ (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) - (dashboard:summary commondat stats-dat tab-num: 0) runs-view + (dashboard:summary commondat stats-dat tab-num: 1) ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) - additional-views))) + additional-views)) + (target-run (dboard:commondat-target commondat)) + ) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Summary") - (iup:attribute-set! tabs "TABTITLE1" "Runs") + (iup:attribute-set! tabs "TABTITLE0" "Runs") + (iup:attribute-set! tabs "TABTITLE1" "Summary") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") @@ -3061,12 +3007,18 @@ (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup - (dboard:common-set-tabdat! commondat 0 stats-dat) - (dboard:common-set-tabdat! commondat 1 runs-dat) + ;; (dboard:common-set-tabdat! commondat 0 stats-dat) + + (if target-run + (begin + (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + ) + ) + (dboard:common-set-tabdat! commondat 0 runs-dat) ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) @@ -3305,11 +3257,10 @@ (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) - (print "reseting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) (vg:drawing-libs-set! dwg (make-hash-table)) (vg:drawing-insts-set! dwg (make-hash-table)) (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) @@ -3819,16 +3770,42 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) - (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + (print "Starting dashboard main") + + (let* ((mtdb-path (conc *toppath* "/.megatest/main.db")) + (target (args:get-arg "-target")) + (commondat (dboard:commondat-make))) + (if target + (begin + (args:remove-arg-from-ht "-target") + (dboard:commondat-target-set! commondat target) + ) + ) + + (if (not (launch:setup)) + (begin + (print "Failed to find megatest.config, exiting") + (exit 1) + ) + ) + + (if (not (common:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower.") + )) + + (if (and (common:file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) - (let* ((commondat (dboard:commondat-make))) + + (let* () ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1) @@ -3841,26 +3818,24 @@ (>= test-id 0)) (dashboard-tests:examine-test run-id test-id) (begin (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) (else (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) + (dashboard:runs-tab-updater commondat 0)) + tab-num: 0) ;; 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) + ;; (dboard:commondat-add-updater + ;; commondat + ;; (lambda () + ;; (dashboard:runs-tab-updater commondat 1)) + ;; tab-num: 2) (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) (let ((update-is-running #f)) (mutex-lock! (dboard:commondat-update-mutex commondat)) @@ -3874,23 +3849,102 @@ (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) (mutex-unlock! (dboard:commondat-update-mutex commondat))) )) 1)))) - + (print "Starting updaters") (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) + (print "Starting main loop") (thread-start! th2) - (thread-join! th2))))) + (thread-join! th2) + ) + ) + ) +) + +(define last-copy-time 0) + + +;; Sync to tmp only if in read-only mode. + +(define (sync-db-to-tmp tabdat) + (let* ((db-file "./.megatest/main.db")) + (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) + (begin + (db:multi-db-sync (db:setup #f) 'old2new) + (set! last-copy-time (current-seconds)) + ) + ) + ) +) + +;; ########################### top level code ######################## +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (for-each (lambda (var) + ;; (display " ")(display var) + (if (get-environment-variable var) + (begin + (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (exit 1)))) + '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) + ) +) + +(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) + +(if (not (null? remargs)) + (if remargs + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + + + + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) + (if (args:get-arg "-repl") (repl) (main)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -684,21 +684,21 @@ (let* ((fname (conc (pathname-file file) ".db")) (fulln (conc *toppath*"/.megatest/"fname)) (time1 (if (file-exists? file) (file-modification-time file) (begin - (debug:print-info 0 *default-log-port* "Sync - I do not see file "file) + (debug:print-info 2 *default-log-port* "Sync - I do not see file "file) 1))) (time2 (if (file-exists? fulln) (file-modification-time fulln) (begin - (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln) + (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln) 0))) (changed (> time1 time2)) (do-cp (cond ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover - (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln) + (debug:print-info 2 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln) #t) (changed ;; (and changed ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. #t) ((and changed *time-to-exit*) ;; last sync @@ -735,41 +735,61 @@ ;; (define (db:multi-db-sync dbstruct . options) (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) (data-synced 0) ;; count of changed records (tmp-area (common:get-db-tmp-area)) - (old2new (member 'old2new options)) + (old2new (member 'old2new options)) + (dejunk (member 'dejunk options)) + (killservers (member 'killservers options)) + (servers (server:get-list *toppath*)) (src-area (if old2new *toppath* tmp-area)) (dest-area (if old2new tmp-area *toppath*)) (dbfiles (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db")))) (keys (db:get-keys dbstruct)) (sync-durations (make-hash-table))) + + (if killservers + (begin + (for-each + (lambda (server) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn) + #f) + (match-let (((mod-time host port start-time server-id pid) server)) + (if (and host pid) + (tasks:kill-server host pid))))) + servers) + (delete-file* (common:get-sync-lock-filepath)) + ) + ) (for-each (lambda (srcfile) (debug:print-info 3 *default-log-port* "file: " srcfile) (let* ((fname (conc (pathname-file srcfile) ".db")) (basename (pathname-file srcfile)) (run-id (if (string= basename "main") #f (string->number basename))) (destfile (conc dest-area "/.megatest/" fname)) (dest-directory (conc dest-area "/.megatest/")) - (dummy (debug:print-info 0 *default-log-port* "destfile = " destfile)) + (dummy (debug:print-info 2 *default-log-port* "destfile = " destfile)) + (dummy2 (debug:print-info 2 *default-log-port* "dejunk = " dejunk)) (time1 (file-modification-time srcfile)) - (time2 (if (file-exists? destfile) (begin - (debug:print-info 0 *default-log-port* "destfile " destfile " exists") + (debug:print-info 2 *default-log-port* "destfile " destfile " exists") (file-modification-time destfile) ) (begin (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) 0))) - (changed (> time1 time2)) + (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds (do-cp (cond ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover - (debug:print-info 0 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) + (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) (system (conc "/bin/mkdir -p " dest-directory)) (system (conc "/bin/cp " srcfile " " destfile)) #t) (changed ;; (and changed ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. @@ -776,26 +796,33 @@ #t) ((and changed *time-to-exit*) ;; last sync #t) (else #f)))) - (if do-cp + (if (or dejunk do-cp) (let* ( (start-time (current-milliseconds)) (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) (mtdb (dbr:subdb-mtdbdat subdb)) (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)) ) - (debug:print-info 0 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") + (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") + (if old2new - (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb) - (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb) + (begin + (if dejunk (db:clean-up run-id mtdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb) + ) + (begin + (if dejunk (db:clean-up run-id tmpdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb) + ) ) (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) - (debug:print-info 0 *default-log-port* "skipping delta sync. " srcfile " is up to date") + (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date") ) ) ) dbfiles ) @@ -1529,54 +1556,20 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) - (db (dbr:dbdat-dbh dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";") - ;; delete all tests that are 'DELETED' - (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;") - ;; delete all tests that have no run - (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ") - ;; delete all runs that are state='deleted' - (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";") - ;; delete empty runs - (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";") - ;; remove orphaned test_rundat entries - (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_steps entries - (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_dat entries - (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);") - - )))) - ;; (db:delay-if-busy dbdat) - ;(debug:print-info 0 *default-log-port* statements) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) +(define (db:clean-up run-id dbdat) + (debug:print 2 *default-log-port* "db:clean-up") + + + (if run-id + (db:clean-up-rundb dbdat) + (db:clean-up-maindb dbdat) + ) +) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -2004,19 +1997,21 @@ (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) res)) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; +;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!! + (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) - (alldbs (glob (conc dbdir "/[0-9]*.db"))) + (alldbs (glob (conc dbdir "/.megatest/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) - (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) + (let* ((res (string-match ".*\\/(\\d\\d)\\.db" dbfile))) (if res (string->number (cadr res)) (begin (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") 0)))) @@ -4372,29 +4367,76 @@ ;;====================================================================== ;; To sync individual run ;;====================================================================== (define (db:get-run-record-ids dbstruct target run keynames test-patt) -(let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (dbdat db) - (let* ((keystr (string-intersperse - (map (lambda (key val) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_tests '()) + (all_test_steps '()) + (all_test_data '()) + (keystr (string-intersperse + (map (lambda (key val) (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) + keynames + (string-split target "/")) + " AND ") + ) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) - (print run-qry) - (print test-qry) - `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) - (tests . ,(sqlite3:fold-row backcons '() db test-qry)) - (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) - (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) - )))))) + (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) + (run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db run-qry)) + ) + ) + ) + (for-each + (lambda (run_id) + (set! all_tests + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM tests WHERE run_id in (" run_id ") and testname like '" test-patt "'")) + ) + ) + ) all_tests + ) + ) + (set! all_test_steps + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")) + ) + ) + ) all_test_steps + ) + ) + (set! all_test_data + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")")) + ) + ) + ) all_test_data + ) + ) + ) + run_ids + ) + `((runs . ,run_ids) + (tests . ,all_tests) + (test_steps . ,all_test_steps) + (test_data . ,all_test_data) + ) + + ) +) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== @@ -4405,11 +4447,18 @@ ;; no transaction, allow the db to be accessed between the big queries (let* ((backcons (lambda (lst item)(cons item lst))) (all_tests '()) (all_test_steps '()) (all_test_data '()) - + (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers + (all_run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs")) + ) + ) + (changed_run_ids (filter (lambda (run) (member (modulo run 100) changed_run_dbs)) all_run_ids)) (run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) ) @@ -4421,16 +4470,16 @@ ) ) ) (for-each (lambda (run_id) - (set! all_tests + (set! all_tests (append (map (lambda (x) (cons x run_id)) (db:with-db dbstruct run_id #f (lambda (dbdat db) - (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time) + (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time) ) ) ) all_tests ) ) @@ -4437,11 +4486,11 @@ (set! all_test_steps (append (map (lambda (x) (cons x run_id)) (db:with-db dbstruct run_id #f (lambda (dbdat db) - (sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time) + (sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time) ) ) ) all_test_steps ) ) @@ -4455,11 +4504,11 @@ ) ) all_test_data ) ) ) - run_ids + changed_run_ids ) (debug:print 2 *default-log-port* "run_ids = " run_ids) (debug:print 2 *default-log-port* "all_tests = " all_tests) `((runs . ,run_ids) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -207,10 +207,11 @@ (conc apath"/"(dbfile:run-id->dbname run-id))) (define (db:dbname->path apath dbname) (conc apath"/"dbname)) +;; POTENTIAL BUG: this implementation could produce a db file if run-id is neither #f or a number (define (dbfile:run-id->dbname run-id) (cond ((number? run-id) (conc ".megatest/" (modulo run-id 100) ".db")) ((not run-id) (conc ".megatest/main.db")) (else run-id))) @@ -256,20 +257,13 @@ (set! *dbfile:num-handles-in-use* (+ *dbfile:num-handles-in-use* 1)) (stack-pop! (dbr:subdb-dbstack subdb)))))) ;; return a previously opened db handle to the stack of available handles (define (dbfile:add-dbdat dbstruct run-id dbdat) - (let* ((subdb (dbfile:get-subdb dbstruct run-id)) - (age (- (current-seconds)(dbr:dbdat-birth-sec dbdat)))) - (if (> age 300) ;; just testing - discard and close after 30 sec - (begin - ;; (map sqlite3:finalize! (hash-table-values (dbr:dbdat-stmt-cache dbdat))) - ;; (sqlite3:finalize! (dbr:dbdat-dbh dbdat)) - (dbfile:print-err "INFO: Discarded dbdat over 30 sec old ("age"s)")) - (begin - (set! *dbfile:num-handles-in-use* (- *dbfile:num-handles-in-use* 1)) - (stack-push! (dbr:subdb-dbstack subdb) dbdat))))) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (set! *dbfile:num-handles-in-use* (- *dbfile:num-handles-in-use* 1)) + (stack-push! (dbr:subdb-dbstack subdb) dbdat))) ;; set up a subdb ;; (define (dbfile:init-subdb dbstruct run-id init-proc) (let* ((dbname (dbfile:run-id->dbname run-id)) @@ -317,12 +311,12 @@ ;; this stuff is for initial debugging, please remove it when ;; this code stabilizes (define *dbopens* (make-hash-table)) (define (dbfile:inc-db-open dbfile) (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1))) - (if (> curr-opens-count 1) ;; this should NOT be happening - (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) + ;; (if (> curr-opens-count 1) ;; this should NOT be happening + ;; (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) (hash-table-set! *dbopens* dbfile curr-opens-count) curr-opens-count)) ;; Open the classic megatest.db file (defaults to open in toppath) ;; @@ -490,46 +484,52 @@ ) (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) ) ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically tmpdb)) -;;====================================================================== -;; no-sync.db - small bits of data to be shared between servers -;;====================================================================== - -;; if we are not a server create a db handle. this is not finalized -;; so watch for problems. I'm still not clear if it is needed to manually -;; finalize sqlite3 dbs with the sqlite3 egg. -;; (define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 50)) + (let* ((busy-file (conc fname"-journal")) (delay-time (* (- 51 tries-left) 1.1)) - (retry (lambda () + (write-access (file-write-access? fname)) + (dir-access (file-write-access? (pathname-directory fname))) + (retry (lambda () (thread-sleep! delay-time) (if (> tries-left 0) (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) - (if (and (file-writable? fname) + (if (and (file-write-access? fname) (file-exists? busy-file)) (begin (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.") (thread-sleep! 1) (if (eq? tries-left 2) (begin (dbfile:print-err "INFO: forcing journal rollup "busy-file) (dbfile:brute-force-salvage-db fname))) (dbfile:cautious-open-database fname init-proc (- tries-left 1))) + (let* ((result (condition-case + (if dir-access (dbfile:with-simple-file-lock (conc fname ".lock") (lambda () (let* ((db-exists (file-exists? fname)) - (db (sqlite3:open-database fname))) + (db (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist. (if (and init-proc (not db-exists)) (init-proc db)) db))) + (begin + (if (file-exists? fname ) + (begin + (sqlite3:open-database fname) + ) + (print "file doesn't exist: " fname) + ) + ) + ) (exn (io-error) (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") (retry)) (exn (corrupt) (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") @@ -610,16 +610,15 @@ (let* ((dbname (conc dbpath "/no-sync.db")) (db-exists (file-exists? dbname)) (init-proc (lambda (db) (if (not db-exists) (begin - (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")) ))) (db (dbfile:cautious-open-database dbname init-proc))) ;; (sqlite3:open-database dbname))) + (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) - ;;(sqlite3:execute db "PRAGMA journal_mode=WAL;") (set! *no-sync-db* db) db)))) (define (db:no-sync-set db var val) (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) @@ -1003,13 +1002,10 @@ ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) - (if (common:low-noise-print 120 "sync-records") - (dbfile:print-err "found " totrecords " records to sync")) - (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (dbr:dbdat-dbh todb) full-sel) @@ -1032,15 +1028,10 @@ (is-trigger-dropped (if has-last-update (db:is-trigger-dropped db tablename) #f)) (stmth (sqlite3:prepare db full-ins)) (changed-rows 0)) - ;; (db:delay-if-busy targdb) ;; NO WAITING - (if (and - has-last-update - (common:low-noise-print 120 "is-trigger-dropped")) - (dbfile:print-err "is-trigger-dropped: " is-trigger-dropped)) (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () @@ -1065,16 +1056,10 @@ ) )) fromdat-lst)))) fromdats) - - (if (> changed-rows 0) - (dbfile:print-err "table " tablename " changed rows: " changed-rows) - ) - - (sqlite3:finalize! stmth) (if (member "last_update" field-names) (db:create-trigger db tablename)))) (append (list todb) slave-dbs) ) @@ -1082,18 +1067,16 @@ ) tbls) (let* ((runtime (- (current-process-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. - (if should-print (dbfile:print-err "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) - (if (> count 0) - (if should-print (dbfile:print-err "FIXME: tblname: " tblname", count: "count" "))))) ;; (format #f " ~10a ~5a" tblname count)))))) + )) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))))) ;;====================================================================== ;; trigger setup/takedown @@ -1220,12 +1203,10 @@ #f)) (use-mutex (> *api-process-request-count* 25))) ;; was 25 (if (and use-mutex (common:low-noise-print 120 "over-50-parallel-api-requests")) (dbfile:print-err *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) - (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) - (dbfile:print-err "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) (condition-case (begin (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let ((res (apply proc dbdat db params))) (if use-mutex (mutex-unlock! *db-with-db-mutex*)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -545,11 +545,14 @@ (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) - (print "Adding xterm code"))))) + ) + ) + ) +) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -618,11 +618,11 @@ (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) ;;(bb-check-path msg: "launch:execute post block 3") - (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + (if mt-bindir-path (setenv "PATH" (conc "\""(getenv "PATH")":"mt-bindir-path"\""))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -1475,12 +1475,12 @@ (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) (if (> launch-delay delta) (begin - (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. - (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) + ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. + ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) (append Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -38,10 +38,15 @@ (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) + +(define (args:remove-arg-from-ht arg) + (hash-table-delete! args:arg-hash arg) +) + (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) (print help) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -18,6 +18,6 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. ;; (declare (unit megatest-version)) -(define megatest-version 1.7004) +(define megatest-version 1.7006) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -2505,11 +2505,10 @@ (db:setup #f) 'killservers 'dejunk 'adj-testids 'old2new - ;; 'new2old ) (set! *didsomething* #t))) (when (args:get-arg "-sync-brute-force") (launch:setup) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -545,10 +545,11 @@ (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-target run-id (list run-id))) (define (rmt:get-run-times runpatt targetpatt) (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) @@ -557,13 +558,15 @@ ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar (define (rmt:register-test run-id test-name item-path) + (assert (number? run-id) "FATAL: Run id required.") (rmt:general-call 'register-test run-id run-id test-name item-path)) (define (rmt:get-test-id run-id testname item-path) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) ;; run-id is NOT used ;; (define (rmt:get-test-info-by-id run-id test-id) @@ -576,39 +579,46 @@ (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) + (assert (number? run-id) "FATAL: Run id required.") (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) -(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) +(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) + (assert (number? run-id) "FATAL: Run id required.") ;; (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) (define (rmt:get-tests-for-run-state-status run-id testpatt last-update) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) @@ -651,40 +661,50 @@ ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) (define (rmt:test-set-state-status run-id test-id state status msg) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (rmt:test-toplevel-num-items run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (rmt:test-get-logfile-info run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) (define (rmt:get-testinfo-state-status run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (rmt:test-set-log! run-id test-id logf) + (assert (number? run-id) "FATAL: Run id required.") (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-set-top-process-pid run-id test-id pid) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (rmt:test-get-top-process-pid run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) @@ -696,57 +716,71 @@ (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (rmt:get-count-tests-running-for-run-id run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) (define (rmt:get-not-completed-cnt run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (rmt:get-count-tests-running-for-testname run-id testname) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) (define (rmt:set-state-status-and-roll-up-run run-id state status) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status))) (define (rmt:update-pass-fail-counts run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) (define (rmt:get-raw-run-stats run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) (define (rmt:get-test-times runname target) (rmt:send-receive 'get-test-times #f (list runname target ))) ;;====================================================================== ;; R U N S ;;====================================================================== +;; BUG - LOOK AT HOW THIS WORKS!!! +;; (define (rmt:get-run-info run-id) - (rmt:send-receive 'get-run-info run-id (list run-id))) + (assert (number? run-id) "FATAL: Run id required.") + (rmt:send-receive 'get-run-info #f (list run-id))) (define (rmt:get-num-runs runpatt) (rmt:send-receive 'get-num-runs #f (list runpatt))) (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys) @@ -755,14 +789,15 @@ ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user contour) (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) (define (rmt:get-run-name-from-id run-id) - (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) + (assert (number? run-id) "FATAL: Run id required.") + (rmt:send-receive 'get-run-name-from-id #f (list run-id))) (define (rmt:delete-run run-id) - (rmt:send-receive 'delete-run run-id (list run-id))) + (rmt:send-receive 'delete-run #f (list run-id))) (define (rmt:update-run-stats run-id stats) (rmt:send-receive 'update-run-stats #f (list run-id stats))) (define (rmt:delete-old-deleted-test-records) @@ -776,43 +811,52 @@ (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-prev-run-ids #f (list run-id))) (define (rmt:lock/unlock-run run-id lock unlock user) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (rmt:get-run-status run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-status #f (list run-id))) (define (rmt:get-run-state run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-state #f (list run-id))) (define (rmt:set-run-status run-id run-status #!key (msg #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-tesdata-on-repilcate-db old-lt new-lt) (rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt))) (define (rmt:update-run-event_time run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) + (assert (number? run-id) "FATAL: Run id required.") ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) (define (rmt:get-main-run-stats run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) @@ -889,38 +933,45 @@ ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) + (assert (number? run-id) "FATAL: Run id required.") (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:delete-steps-for-test! run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id))) (define (rmt:get-steps-for-test run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) (define (rmt:get-steps-info-by-id run-id test-step-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-steps-info-by-id #f (list run-id test-step-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt))) (define (rmt:get-data-info-by-id run-id test-data-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-data-info-by-id #f (list run-id test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) @@ -929,13 +980,15 @@ (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== @@ -983,10 +1036,11 @@ (define (rmt:archive-register-disk bdisk-name bdisk-path df) (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) (define (rmt:test-set-archive-block-id run-id test-id archive-block-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (rmt:test-get-archive-block-info archive-block-id) (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -333,10 +333,25 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) +(define *last-test-launch* 0) +(define *too-soon-delays* (make-hash-table)) + +;; to-soon delay, when matching event happened in less than dseconds delay wseconds +;; +(define (runs:too-soon-delay key dseconds wseconds) + (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f))) + (if (and last-time + (< (- (current-seconds) last-time) dseconds)) + (begin + (if (runs:lownoise (conc "too-soon-delay"key) 60) + (debug:print-info 2 *default-log-port* "Polling throttle for "key)) + (thread-sleep! wseconds))) + (hash-table-set! *too-soon-delays* key (current-seconds)))) + (define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) ;; Take advantage of a good place to exit if running the one-pass methodology (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) (args:get-arg "-one-pass")) @@ -1308,10 +1323,11 @@ ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry runsdat testdat) + (set! *last-test-launch* (current-seconds)) (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) @@ -1676,11 +1692,16 @@ (debug:print-info 2 *default-log-port* "Excessively fast loop, delaying 1/2 second")) (thread-sleep! 0.5))) (set! *last-loop-time-ms* (current-milliseconds)) (runs:dat-regfull-set! runsdat regfull) - + + + (if (> (- (current-seconds) *last-test-launch*) 5) ;; be pretty aggressive for five seconds after + (runs:too-soon-delay (conc "loop delay " hed) 1 0.6) ;; starting a test then apply more delay + (runs:too-soon-delay (conc "loop delay " hed) 1 0.1)) + (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) @@ -1925,11 +1946,11 @@ (rmt:set-var (conc "lunch-complete-" run-id) "yes") ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle + (thread-sleep! 0.1) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -595,17 +595,19 @@ (if (equal? *toppath* toppath) #t #f))) ;; timeout is hms string: 1h 5m 3s, default is 1 minute +;; This is currently broken. Just use the number of hours with no unit. +;; Default is 60 seconds. ;; (define (server:expiration-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) - 60))) + 1200))) (define (server:get-best-guess-address hostname) (let ((res #f)) (for-each (lambda (adr) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -62,11 +62,11 @@ (define (subrun:launch-dashboard test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let* ((subarea (subrun:get-runarea test-run-dir))) (if (and subarea (common:file-exists? subarea)) - (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) + (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) (define (subrun:subrun-removed? test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (common:file-exists? flagfile) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -903,14 +903,18 @@ (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug test-step-ids))) (define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) (let ((test-ht (hash-table-ref cached-info 'tests)) - (data-ht (hash-table-ref cached-info 'data))) + (data-ht (hash-table-ref cached-info 'data)) + (run-id-in #f) + ) (for-each (lambda (test-data-id) - (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) + (set! run-id-in (cdr test-data-id)) + (set! test-data-id (car test-data-id)) + (let* ((test-data-info (rmt:get-data-info-by-id run-id-in test-data-id)) (data-id (db:test-data-get-id test-data-info)) (test-id (db:test-data-get-test_id test-data-info)) (category (db:test-data-get-category test-data-info)) (variable (db:test-data-get-variable test-data-info)) (value (db:test-data-get-value test-data-info)) @@ -1059,45 +1063,45 @@ (print "In sync") (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds)) - (test-patt (if (args:get-arg "-testpatt") - (args:get-arg "-testpatt") + (test-patt (if (args:get-arg "-testpatt") + (args:get-arg "-testpatt") "%")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - #f)) - (run-name (if (args:get-arg "-runname") - (args:get-arg "-runname") - #f))) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + (run-name (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f))) (if (and target (not run-name)) (begin - (print "Error: Provide runname") + (print "Error: Provide runname") (exit 1))) (if (and (not target) run-name) (begin - (print "Error: Provide target") + (print "Error: Provide target") (exit 1))) ;(print "123") - ;(exit 1) + ;(exit 1) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info - (let* ((last-sync-time (vector-ref area-info 3)) + (let* ((last-sync-time (if (args:get-arg "-since") (string->number (args:get-arg "-since")) (vector-ref area-info 3))) (smallest-last-update-time (make-hash-table)) - (changed (if (and target run-name) + (changed (if (and target run-name) (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt) (rmt:get-changed-record-ids last-sync-time))) (run-ids (alist-ref 'runs changed)) (test-ids (alist-ref 'tests changed)) (test-step-ids (alist-ref 'test_steps changed)) (test-data-ids (alist-ref 'test_data changed)) (run-stat-ids (alist-ref 'run_stats changed)) - (area-tag (if (args:get-arg "-area-tag") + (area-tag (if (args:get-arg "-area-tag") (args:get-arg "-area-tag") (if (args:get-arg "-area") (args:get-arg "-area") "")))) (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -25,10 +25,11 @@ (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) +(declare (uses commonmod)) ;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (declare (uses server)) @@ -59,10 +60,11 @@ srfi-18 srfi-69 system-information regex + commonmod ) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -1800,11 +1802,11 @@ )))))) ;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain") (define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats - (let-values (((inp oup pid)(process "env -i PATH=$PATH dot" (list "-T" outtype)))) + (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype)))) (with-output-to-port oup (lambda () (map print indat))) (close-output-port oup) (let ((res (with-input-from-port inp @@ -1822,14 +1824,14 @@ (tests:write-dot-file testrecords dfile sizex sizey) (if (common:file-exists? fname) (let ((res (with-input-from-file fname (lambda () (read-lines))))) - (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&")) + (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&")) res) (begin - (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname)) + (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname)) (with-input-from-file fname (lambda () (read-lines))))))) Index: utils/mt-old-to-new.sh ================================================================== --- utils/mt-old-to-new.sh +++ utils/mt-old-to-new.sh @@ -1,6 +1,12 @@ #!/bin/bash +if [ -d ".megatest" ] +then + echo ".megatest directory present." + echo "You have already migrated. " + exit +fi mkdir -p .megatest cp megatest.db .megatest/main.db sqlite3 .megatest/main.db << END_SQL delete from tests; @@ -12,17 +18,24 @@ sqlite3 megatest.db 'select id from runs' > runs.txt for run in $(cat runs.txt) do + echo "working on run id $run" dbnum=$(($run%100)) - cp megatest.db .megatest/$dbnum.db - sqlite3 .megatest/$dbnum.db << END_SQL - delete from tests where run_id != $run; - delete from test_data; - delete from test_meta; - delete from test_rundat; - delete from test_steps where not exists ( select id from tests where tests.id = test_steps.test_id); - replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version'); + if [ ! -f ".megatest/$dbnum.db" ] + then + dbnum=$(($run%100)) + cp megatest.db .megatest/$dbnum.db + sqlite3 .megatest/$dbnum.db << END_SQL + delete from tests where run_id in (select id from runs where id%100!=$dbnum); + delete from test_data; + delete from test_meta; + delete from test_rundat; + delete from test_steps where not exists ( select id from tests where tests.id = test_steps.test_id); + replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version'); + VACUUM; END_SQL + + fi done Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -31,11 +31,11 @@ exit fi # Since the user may not have . on the path and since we are likely to want to # run test scripts in the current directory add the current dir to the path -export PATH=$PATH:$PWD +export PATH="$PATH:$PWD" testrundir=$1; shift stepname=$1;shift command=$* Index: utils/mt_xterm ================================================================== --- utils/mt_xterm +++ utils/mt_xterm @@ -16,14 +16,25 @@ # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see . MT_TMPDISPLAY=$DISPLAY -if [ -e megatest.sh ];then - source megatest.sh -fi +MT_TMPUSER=$USER +MT_HOME=$HOME + +tmpfile=`mktemp` + +grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile +source $tmpfile +rm $tmpfile + +# if [ -e megatest.sh ];then +#source megatest.sh +#fi export DISPLAY=$MT_TMPDISPLAY +export USER=$USER +export HOME=$MT_HOME if [ x"$MT_XTERM_CMD" == "x" ];then exec xterm "$@" else exec $MT_XTERM_CMD Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -96,10 +96,10 @@ #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely - ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" + ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi