@@ -50,19 +50,31 @@ (include "megatest-fossil-hash.scm") (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) + +(define *area-dat* (make-megatest:area + "default" ;; area name + #f ;; area path + 'http ;; transport + #f ;; configinfo + #f ;; configdat + (make-hash-table) ;; denoise + #f ;; client signature + #f ;; remote connections + )) + ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright Matt Welland 2006-2012 + license GPL, Copyright Matt Welland 2006-2015 Usage: megatest [options] -h : this help -version : print megatest version (currently " megatest-version ") @@ -301,11 +313,12 @@ (define *time-zero* (current-seconds)) (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db")) + ;; the query to get megatest-db setting might not work, forcing it to be default on. Use "no" to turn off + (let ((legacy-sync (configf:lookup (megatest:area-configdat *area-dat*) "setup" "megatest-db")) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) (let loop () ;; sync for filesystem local db writes ;; @@ -312,11 +325,11 @@ (let ((start-time (current-seconds)) (servers-started (make-hash-table))) (for-each (lambda (run-id) (mutex-lock! *db-multi-sync-mutex*) - (if (and legacy-sync + (if (and (not (equal? legacy-sync "no")) (hash-table-ref/default *db-local-sync* run-id #f)) ;; (if (> (- start-time last-write) 5) ;; every five seconds (begin ;; let ((sync-time (- (current-seconds) start-time))) (db:multi-db-sync (list run-id) 'new2old) (if (common:low-noise-print 30 "sync new to old") @@ -427,11 +440,11 @@ (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") - (let ((toppath (launch:setup-for-run))) + (let ((toppath (launch:setup-for-run *area-dat*))) (print (string-intersperse (map (lambda (x) (string-intersperse x @@ -636,11 +649,11 @@ (if (args:get-arg "-server") ;; Server? Start up here. ;; - (let ((tl (launch:setup-for-run)) + (let ((tl (launch:setup-for-run *area-dat*)) (run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) @@ -656,11 +669,11 @@ '("-list-servers" "-stop-server" "-show-cmdinfo" "-list-runs" "-ping"))) - (if (launch:setup-for-run) + (if (launch:setup-for-run *area-dat*) (let ((run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") @@ -676,11 +689,11 @@ ;; MAY STILL NEED THIS ;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) - (let ((tl (launch:setup-for-run))) + (let ((tl (launch:setup-for-run *area-dat*))) (if tl (let* ((tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) @@ -753,11 +766,11 @@ (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) data)) (if (args:get-arg "-show-runconfig") - (let ((tl (launch:setup-for-run))) + (let ((tl (launch:setup-for-run *area-dat*))) (push-directory *toppath*) (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((and (args:get-arg "-section") @@ -772,11 +785,11 @@ (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") - (let ((tl (launch:setup-for-run)) + (let ((tl (launch:setup-for-run *area-dat*)) (data *configdat*)) ;; (read-config "megatest.config" #f #t))) (push-directory *toppath*) ;; keep this one local (cond ((and (args:get-arg "-section") @@ -878,11 +891,11 @@ ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) - (if (launch:setup-for-run) + (if (launch:setup-for-run *area-dat*) (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) @@ -1102,11 +1115,11 @@ (change-directory toppath) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote @@ -1190,11 +1203,11 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) (rmt:teststep-set-status! run-id test-id step state status msg logfile) @@ -1238,11 +1251,11 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) @@ -1343,11 +1356,11 @@ (if (or (args:get-arg "-showkeys") (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) - (if (not (launch:setup-for-run)) + (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)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) @@ -1374,21 +1387,21 @@ ;; Update the database schema, clean up the db ;;====================================================================== (if (args:get-arg "-rebuild-db") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close db:clean-up #f) @@ -1403,11 +1416,11 @@ ) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") b (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) @@ -1416,11 +1429,11 @@ ;; Update the tests meta data from the testconfig files ;;====================================================================== (if (args:get-arg "-update-meta") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local @@ -1434,11 +1447,11 @@ ;; fakeout readline (define (toplevel-command . a) #f) (if (or (args:get-arg "-repl") (args:get-arg "-load")) - (let* ((toppath (launch:setup-for-run)) + (let* ((toppath (launch:setup-for-run *area-dat*)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (if dbstruct (begin (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) @@ -1463,11 +1476,11 @@ ;;====================================================================== (if (and (args:get-arg "-run-wait") (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t)))