Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3) +(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3 call-with-environment-variables) (require-extension sqlite3 regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -35,24 +35,27 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES -(define *db-keys* #f) -(define *configinfo* #f) -(define *configdat* #f) -(define *toppath* #f) -(define *already-seen-runconfig-info* #f) -(define *waiting-queue* (make-hash-table)) -(define *test-meta-updated* (make-hash-table)) -(define *globalexitstatus* 0) ;; attempt to work around possible thread issues -(define *passnum* 0) ;; when running track calls to run-tests or similar -(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) -(define *alt-log-file* #f) ;; used by -log -(define *common:denoise* (make-hash-table)) ;; for low noise printing - -;; MULTI-TESTSUITE support +;; (define *db-keys* #f) +;; (define *configinfo* #f) +;; (define *configdat* #f) +;; (define *toppath* #f) +;; (define *already-seen-runconfig-info* #f) +;; (define *waiting-queue* (make-hash-table)) +;; (define *test-meta-updated* (make-hash-table)) +;; (define *globalexitstatus* 0) ;; attempt to work around possible thread issues +;; (define *passnum* 0) ;; when running track calls to run-tests or similar +;; (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) +;; (define *alt-log-file* #f) ;; used by -log +;; (define *common:denoise* (make-hash-table)) ;; for low noise printing + +;; All the above *theoretically* replaced by ... +(define *testsuite-data* (make-hash-table)) ;; area-path => testsuite-vector < toppath linktree configdat envvars dbstruct > + +;; MULTI-TESTSUITE support, use when the env-vars are in use (set up and take down using call-with-environment-variables.) (define *testsuite-mutex* (make-mutex)) ;; DATABASE (define *dbstruct-db* #f) (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > @@ -148,48 +151,64 @@ environ-patt: "env-override" given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME"))) (configdat (if (car configinfo)(car configinfo) #f)) (toppath (if (car configinfo)(cadr configinfo) #f)) - (linktree (configf:lookup configdat "setup" "linktree"))) ;; link tree is critical + (linktree (configf:lookup configdat "setup" "linktree")) ;; link tree is critical + (failed #f)) (if linktree (if (not (file-exists? linktree)) (begin (handle-exceptions exn (begin (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (set! failed #t)) (create-directory linktree #t)))) (begin (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") - (exit 1))) + (set! failed #t))) (if linktree (let ((dbdir (or (configf:lookup configdat "setup" "dbdir") ;; not really supported yet, placeholder only (conc linktree "/.db")))) (handle-exceptions exn (begin (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (set! failed #t)) (if (not (directory-exists? dbdir))(create-directory dbdir)))) ;; (setenv "MT_LINKTREE" linktree)) (begin (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") - ;; (exit 1) - ) - ) + (set! failed #t))) (if (not (and toppath (directory-exists? toppath))) - ;; (setenv "MT_RUN_AREA_HOME" *toppath*) (begin - (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))) - ;; (exit 1))) + (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") + (set! failed #t))) + (mutex-unlock! *testsuite-mutex*) + (let ((testsuite-data (vector toppath linktree configinfo + (list (cons "MT_LINKTREE" linktree) + (cons "MT_RUN_AREA_HOME" toppath)) + #f))) + (if failed + #f + (begin + (hash-table-set! *testsuite-data* toppath testsuite-data) + testsuite-data))))) + +;; get the vars from the testsuite-data envvars store and run proc +;; +(define (common:with-vars testsuite-data proc . additional-vars) + (mutex-lock! *testsuite-mutex*) + (let* ((envvars (append (common_records:testsuite-get-envvars testsuite-data) + additional-vars)) + (res (call-with-environment-variables envvars proc))) (mutex-unlock! *testsuite-mutex*) - (vector toppath linktree configinfo - (list (cons "MT_LINKTREE" linktree) - (cons "MT_RUN_AREA_HOME" toppath))))) + res)) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -102,19 +102,21 @@ ;;====================================================================== ;; T E S T S U I T E R E C O R D S ;;====================================================================== ;; make-vector-record common_records testsuite toppath linktree configdat envvars -(define (make-common_records:testsuite)(make-vector 4)) +(define (make-common_records:testsuite)(make-vector 5)) (define-inline (common_records:testsuite-get-toppath vec) (vector-ref vec 0)) (define-inline (common_records:testsuite-get-linktree vec) (vector-ref vec 1)) (define-inline (common_records:testsuite-get-configdat vec) (vector-ref vec 2)) (define-inline (common_records:testsuite-get-envvars vec) (vector-ref vec 3)) +(define-inline (common_records:testsuite-get-dbstruct vec) (vector-ref vec 4)) (define-inline (common_records:testsuite-set-toppath! vec val)(vector-set! vec 0 val)) (define-inline (common_records:testsuite-set-linktree! vec val)(vector-set! vec 1 val)) (define-inline (common_records:testsuite-set-configdat! vec val)(vector-set! vec 2 val)) (define-inline (common_records:testsuite-set-envvars! vec val)(vector-set! vec 3 val)) +(define-inline (common_records:testsuite-set-dbstruct! vec val)(vector-set! vec 4 val)) (define (common_records:testsuite-add-envvar! vec var val) (let ((envvars (cons (cons var val) (or (common_records:testsuite-get-envvars vec) '())))) (common_records:testsuite-set-envvars! vec envvars) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -567,14 +567,14 @@ (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))) ;; (exit 1))) (mutex-unlock! *testsuite-mutex*) configinfo)) -(define (launch:cache-config) +(define (launch:cache-config testsuite-data) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg - (if (and *configdat* + (if (and testsuite-data ;; *configdat* (args:get-arg "-runtests")) (let* ((linktree (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname"))) @@ -590,11 +590,11 @@ runname (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg"))) (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") - (configf:write-alist *configdat* tmpfile) + (configf:write-alist testsuite-data tmpfile) (system (conc "ln -sf " tmpfile " " targfile)) ))))))) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -300,36 +300,36 @@ (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")) + (let (;; (legacy-sync (configf:lookup *configdat* "setup" "megatest-db")) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) (let loop () ;; sync for filesystem local db writes ;; (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 - (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") - (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) - ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run - ;; (begin - ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) - ;; (server:kind-run run-id))))) - (hash-table-delete! *db-local-sync* run-id))) - (mutex-unlock! *db-multi-sync-mutex*)) - (hash-table-keys *db-local-sync*)) + ;; (for-each + ;; (lambda (run-id) + ;; (mutex-lock! *db-multi-sync-mutex*) + ;; (if (and legacy-sync + ;; (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") + ;; (let ((sync-time (- (current-seconds) start-time))) + ;; (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + ;; ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run + ;; ;; (begin + ;; ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; ;; (server:kind-run run-id))))) + ;; (hash-table-delete! *db-local-sync* run-id))) + ;; (mutex-unlock! *db-multi-sync-mutex*)) + ;; (hash-table-keys *db-local-sync*)) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) (debug:print-info 1 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) @@ -655,11 +655,12 @@ '("-list-servers" "-stop-server" "-show-cmdinfo" "-list-runs" "-ping"))) - (if (launch:setup-for-run) + (let ((testsuite-data (common:multi-setup-for-run))) + (if testsuite-data ;; (launch:setup-for-run) (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") @@ -668,11 +669,11 @@ (begin ;; (if run-id ;; (client:launch run-id) ;; (client:launch 0) ;; without run-id we'll start a server for "0" #t - )))))) + ))))))) ;; MAY STILL NEED THIS ;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1661,24 +1661,32 @@ (exit 3)) ((not runname) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else - (let (;; (db #f) - (keys #f)) - (if (launch:setup-for-run) - (launch:cache-config) + (let* ((keys #f) + (testsuite-data (common:multi-setup-for-run)) + (configdat (common_records:testsuite-get-configdat testsuite-data)) + (toppath (common_records:testsuite-get-toppath testsuite-data))) + (if testsuite-data + (common:with-vars + testsuite-data + (lambda () + (launch:cache-config testsuite-data))) (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*)) + (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))) + (let* ((runconfigf (conc toppath "/runconfigs.config")) ;; DO NOT EVALUATE ALL + (runconfig (common:with-vars + testsuite-data + (lambda () + (read-config runconfigf #f #t environ-patt: #f))))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) @@ -1685,19 +1693,18 @@ ;; (if db (sqlite3:finalize! db)) (exit 1) ))) (if (args:get-arg "-target") (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) - (if (not (car *configinfo*)) + (if testsuite-data ;; (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keyvals (keys:target->keyval keys target))) (proc target runname keys keyvals))) - ;; (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))))) ;;====================================================================== ;; Lock/unlock runs ;;======================================================================