Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -43,12 +43,12 @@ (define (dtests:get-pre-command area-dat #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) -(define (dtests:get-post-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) +(define (dtests:get-post-command area-dat #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "post-command"))) (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame @@ -302,11 +302,12 @@ (if wtxtbox (begin (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) - )))) + )) + area-dat)) (begin (rmt:test-set-state-status-by-id run-id test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) @@ -319,12 +320,12 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) -(define (dashboard-tests:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) +(define (dashboard-tests:run-html-viewer lfilename area-dat) + (let ((htmlviewercmd (configf:lookup (megatest:area-configdat area-dat) "setup" "htmlviewercmd"))) (if htmlviewercmd (system (conc "(" htmlviewercmd " " lfilename " ) &")) (iup:send-url lfilename)))) (define (dashboard-tests:run-a-step info) @@ -353,12 +354,12 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) - (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd area-dat) + (let* ((wpatt (configf:lookup (megatest:area-configdat area-dat) "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) @@ -399,13 +400,13 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") +(define (examine-test run-id test-id area-dat) ;; run-id run-key origtest) + (let* ((db-path (db:dbfile-path run-id)) + (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) local: #t)) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) @@ -443,18 +444,18 @@ "/")) (item-path (db:test-get-item-path testdat)) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer logfile) + (dashboard-tests:run-html-viewer logfile area-dat) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) (if (file-exists? lfilename) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer lfilename) + (dashboard-tests:run-html-viewer lfilename area-dat) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) @@ -542,13 +543,13 @@ lbl)) (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (let* ((cmd (iup:attribute command-text-box "VALUE")) - (fullcmd (conc (dtests:get-pre-command) + (fullcmd (conc (dtests:get-pre-command area-dat) cmd - (dtests:get-post-command)))) + (dtests:get-post-command area-dat)))) (debug:print-info 02 "Running command: " fullcmd) (system fullcmd))))) (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" @@ -579,13 +580,13 @@ ";megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))) - (system (conc (dtests:get-pre-command) + (system (conc (dtests:get-pre-command area-dat) cmd - (dtests:get-post-command)))))) + (dtests:get-post-command area-dat)))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -129,13 +129,14 @@ (define (update-search x val) (hash-table-set! *searchpatts* x val)) ;; mtest is actually the megatest.config file ;; -(define (mtest window-id) - (let* ((curr-row-num 0) - (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) +(define (mtest window-id area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (curr-row-num 0) + (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) (keys-matrix (dcommon:keys-matrix rawconfig)) (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) (jobtools-matrix (iup:matrix #:expand "YES" #:numcol 1 Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -121,11 +121,11 @@ ;; (define (db:get-filedb dbstruct run-id) ;; (let ((db (vector-ref dbstruct 2))) ;; (if db ;; db -;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) +;; (let ((fdb (filedb:open-db (conc toppath "/db/files.db")))) ;; (vector-set! dbstruct 2 fdb) ;; fdb)))) ;; ;; ;; Can also be used to save arbitrary strings ;; ;; @@ -193,11 +193,11 @@ (debug:print 0 "ERROR: no such db in non-writable dir " fname) (sqlite3:open-database fname)))))) ;; This routine creates the db. It is only called if the db is not already opened ;; -(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc toppath "/megatest.db") (car configinfo))) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb @@ -257,11 +257,11 @@ ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem)))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-main dbstruct) ;; (conc toppath "/megatest.db") (car configinfo))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb (let* ((dbpath (db:dbfile-path 0)) (dbexists (file-exists? dbpath)) @@ -276,18 +276,19 @@ dbdat)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; -(define (db:open-megatest-db) - (let* ((dbpath (conc *toppath* "/megatest.db")) +(define (db:open-megatest-db area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (conc toppath "/megatest.db")) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) @@ -769,11 +770,11 @@ ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) (define (db:initialize-main-db dbdat area-dat) - (let* ((configdat (megatest:area-configdat area-dat)) ;; (car *configinfo*)) ;; tut tut, global warning... + (let* ((configdat (megatest:area-configdat area-dat)) ;; (car configinfo)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys)) (db (db:dbdat-get-db dbdat))) @@ -1079,12 +1080,13 @@ ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== -(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) +(define (open-logging-db area-dat) ;; (conc toppath "/megatest.db") (car configinfo))) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) @@ -1443,11 +1445,11 @@ ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change -;; why get the keys from the db? why not get from the *configdat* +;; why get the keys from the db? why not get from the configdat ;; using keys:config-get-fields? (define (db:get-keys dbstruct) (let ((res '())) (db:with-db dbstruct #f #f @@ -2830,14 +2832,14 @@ sync set-verbosity killserver )) -(define (db:login dbstruct calling-path calling-version run-id client-signature) +(define (db:login dbstruct area-dat calling-path calling-version run-id client-signature) (cond - ((not (equal? calling-path *toppath*)) - (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) + ((not (equal? calling-path (megatest:area-path area-dat))) + (list #f "Login failed due to mismatch paths: " calling-path ", " (megatest:area-path area-dat))) ((not (equal? *run-id* run-id)) (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -389,11 +389,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:attribute-set! keys-matrix "WIDTHDEF" "40") keys-matrix)) ;; Section to table @@ -415,11 +415,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:vbox (iup:label (if title title (conc "Settings from [" sectionname "]")) ;; #:size "5x" #:expand "HORIZONTAL" @@ -441,11 +441,11 @@ ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area ;; (iup:attribute-set! general-matrix "2:0" "Area") - ;; (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; (iup:attribute-set! general-matrix "2:1" toppath) ;; Megatest version (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -59,21 +59,22 @@ (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) -(define (http-transport:run hostn run-id server-id) +(define (http-transport:run hostn run-id server-id area-dat) (debug:print 2 "Attempting to start the server ...") - (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily + (let* ((configdat (megatest:area-configdat area-dat)) + (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) + (link-tree-path (configf:lookup configdat "setup" "linktree"))) ;; (set! db *inmemdb*) (debug:print-info 0 "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! @@ -94,11 +95,11 @@ (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) - (send-response body: (api:process-request *inmemdb* $) ;; the $ is the request vars proc + (send-response body: (api:process-request *inmemdb* area-dat $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) @@ -114,17 +115,17 @@ ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) (else (continue)))))))) - (http-transport:try-start-server run-id ipaddrstr start-port server-id))) + (http-transport:try-start-server run-id ipaddrstr start-port server-id area-dat))) ;; This is recursively run by http-transport:run until sucessful ;; -(define (http-transport:try-start-server run-id ipaddrstr portnum server-id) - (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) - (tdbdat (tasks:open-db))) +(define (http-transport:try-start-server run-id ipaddrstr portnum server-id area-dat) + (let ((config-hostname (configf:lookup (megatest:area-configdat area-dat) "server" "hostname")) + (tdbdat (tasks:open-db area-dat))) (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) (handle-exceptions exn (begin (print-error-message exn) @@ -139,11 +140,12 @@ ;; get_next_port goes here (http-transport:try-start-server run-id ipaddrstr (portlogger:open-run-close portlogger:find-port) - server-id)) + server-id + area-dat)) (begin (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") (print "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) @@ -470,11 +472,11 @@ ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) ;; ;; no_traffic, no running tests, if server 0, no running servers ;; - ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) + ;; (let ((wait-on-running (configf:lookup configdat "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) ;; (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin @@ -522,11 +524,11 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; -(define (http-transport:launch run-id) +(define (http-transport:launch run-id area-dat) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) @@ -556,11 +558,12 @@ (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") run-id - server-id)) "Server run")) + server-id + area-dat)) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 "Server monitor thread started") (http-transport:keep-running server-id run-id)) "Keep running"))) (thread-start! th2) @@ -602,15 +605,16 @@ ;;====================================================================== ;; web pages ;;====================================================================== -(define (http-transport:main-page) - (let ((linkpath (root-path))) - (conc "

" (pathname-strip-directory *toppath*) "

" +(define (http-transport:main-page area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (linkpath (root-path))) + (conc "

" (pathname-strip-directory toppath) "

" "" - "Run area: " *toppath* + "Run area: " toppath "

Server Stats

" (http-transport:stats-table) "
" (http-transport:runs linkpath) "
" Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -127,12 +127,12 @@ '() #f))) res))) ;; Nope, not now, return null as of 6/6/2011 -(define (items:check-valid-items class item) - (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) +(define (items:check-valid-items class item area-dat) + (let ((valid-values (let ((s (config-lookup (megatest:area-configdat area-dat) "validvalues" class))) (if s (string-split s) #f)))) (if valid-values (if (member item valid-values) item #f) item))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -212,26 +212,26 @@ (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys area-dat)) - ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process + ;; (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup-for-run area-dat force: #t)) (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) - (change-directory *toppath*) + (change-directory toppath) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? - (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) - ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc toppath "/runconfigs.config") #f #t sections: (list "default" target)))) + ;; (setup-env-defaults (conc toppath "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (let ((var (car varval)) @@ -272,11 +272,11 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) - (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) + (list "MT_LINKTREE" (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now @@ -283,11 +283,11 @@ ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -432,11 +432,12 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) -(on-exit std-exit-procedure) +(on-exit (lambda () + (std-exit-procedure *area-dat*))) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -451,11 +452,11 @@ (string-intersperse (map (lambda (x) (string-intersperse x " => ")) - (common:get-disks *configdat*)) + (common:get-disks (megatest:area-configdat *area-dat*))) "\n")) (set! *didsomething* #t))) (define (make-sparse-array) (let ((a (make-sparse-vector))) @@ -636,18 +637,10 @@ (if (args:get-arg "-ping") (let* ((run-id (string->number (args:get-arg "-run-id"))) (host:port (args:get-arg "-ping"))) (server:ping run-id host:port))) -;; (set! *did-something* #t) -;; (begin -;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port)))) -;; (case (server:get-transport) -;; ((http)(http:ping run-id host-port)) -;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) -;; (else (debug:print 0 "ERROR: No transport set")(exit))))) - ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== @@ -676,11 +669,11 @@ "-list-runs" "-ping"))) (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"))) + ;; (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") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed") (begin @@ -689,11 +682,11 @@ ;; (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)))))))))) +;; (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 *area-dat*))) (if tl @@ -754,28 +747,29 @@ ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) -(define (full-runconfigs-read) - (let* ((keys (rmt:get-keys)) - (target (common:args-get-target)) +(define (full-runconfigs-read area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (keys (rmt:get-keys)) + (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_RUN_AREA_HOME" toppath) (if key-vals (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals)) - (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + (read-config (conc toppath "/runconfigs.config") #f #t sections: sections)))) data)) (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup-for-run *area-dat*))) - (push-directory *toppath*) + (push-directory (megatest:area-path *area-dat*)) (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((and (args:get-arg "-section") (args:get-arg "-var")) @@ -790,12 +784,12 @@ (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") (let ((tl (launch:setup-for-run *area-dat*)) - (data *configdat*)) ;; (read-config "megatest.config" #f #t))) - (push-directory *toppath*) + (data (megatest:area-configdat *area-dat*))) + (push-directory (megatest:area-path *area-dat*)) ;; keep this one local (cond ((and (args:get-arg "-section") (args:get-arg "-var")) (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) @@ -822,13 +816,14 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on action) - (let* ((runrec (runs:runrec-make-record)) - (target (common:args-get-target))) +(define (operate-on action area-dat) + (let* ((runrec (runs:runrec-make-record)) + (target (common:args-get-target)) + (configinfo (megatest:area-configinfo area-dat))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") (exit 1)) ((not (or (args:get-arg ":runname") @@ -837,19 +832,20 @@ (exit 2)) ((not (args:get-arg "-testpatt")) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else - (if (not (car *configinfo*)) + (if (not (car configinfo)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:operate-on action target (or (args:get-arg "-runname")(args:get-arg ":runname")) (args:get-arg "-testpatt") + area-dat state: (or (args:get-arg "-state")(args:get-arg ":state") ) status: (or (args:get-arg "-status")(args:get-arg ":status")) new-state-status: (args:get-arg "-set-state-status"))) (set! *didsomething* #t))))) @@ -899,11 +895,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 *area-dat*) - (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (keys (db:get-keys dbstruct)) @@ -1174,11 +1170,11 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (let ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -187,22 +187,23 @@ (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) -(define (mt:lazy-read-test-config test-name) - (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) +(define (mt:lazy-read-test-config test-name area-dat) + (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)) + (configdat (megatest:area-configdat area-dat))) (if tconf tconf - (let ((test-dirs (tests:get-tests-search-path *configdat*))) + (let ((test-dirs (tests:get-tests-search-path configdat area-dat))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) - (let ((link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (let ((link-tree-path (configf:lookup configdat "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree @@ -209,9 +210,9 @@ (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin - (debug:print 0 "ERROR: No readable testconfig found for " test-name) + (debug:print-info 0 "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -83,11 +83,11 @@ ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. @@ -129,13 +129,13 @@ (define (update-search x val) (hash-table-set! *searchpatts* x val)) ;; mtest is actually the megatest.config file ;; -(define (mtest window-id) +(define (mtest window-id area-dat) (let* ((curr-row-num 0) - (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) + (rawconfig (read-config (conc (megatest:area-path area-dat) "/megatest.config") #f 'return-string)) (keys-matrix (dcommon:keys-matrix rawconfig)) (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) (jobtools-matrix (iup:matrix #:expand "YES" #:numcol 1 @@ -579,21 +579,21 @@ ;;====================================================================== ;; D A S H B O A R D ;;====================================================================== ;; Main Panel -(define (main-panel window-id) +(define (main-panel window-id area-dat) (iup:dialog #:title "Megatest Control Panel" #:menu (dcommon:main-menu) #:shrink "YES" (let ((tabtop (iup:tabs - (runs window-id) - (tests window-id) - (runcontrol window-id) - (mtest window-id) - (rconfig window-id) + (runs window-id area-dat) + (tests window-id area-dat) + (runcontrol window-id area-dat) + (mtest window-id area-dat) + (rconfig window-id area-dat) ))) (iup:attribute-set! tabtop "TABTITLE0" "Runs") (iup:attribute-set! tabtop "TABTITLE1" "Tests") (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") Index: nmsg-transport.scm ================================================================== --- nmsg-transport.scm +++ nmsg-transport.scm @@ -61,11 +61,11 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== -(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000)) +(define (nmsg-transport:run dbstruct area-dat hostn run-id server-id #!key (retrynum 1000)) (debug:print 2 "Attempting to start the server ...") (let* ((start-port (portlogger:open-run-close portlogger:find-port)) (server-thread (make-thread (lambda () (nmsg-transport:try-start-server dbstruct run-id start-port server-id)) "server thread")) @@ -79,19 +79,19 @@ (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access ;; (set! *inmemdb* dbstruct) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") (thread-start! (make-thread - (lambda ()(nmsg-transport:keep-running server-id run-id)) + (lambda ()(nmsg-transport:keep-running server-id run-id area-dat)) "keep running")) (thread-join! server-thread)) (if (> retrynum 0) (begin (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") (portlogger:open-run-close portlogger:set-failed start-port) - (nmsg-transport:run dbstruct hostn run-id server-id)) + (nmsg-transport:run dbstruct area-dat hostn run-id server-id)) (begin (debug:print 0 "ERROR: could not find an open port to start server on. Giving up") (exit 1)))))) (define (nmsg-transport:try-start-server dbstruct run-id portnum server-id) @@ -105,11 +105,11 @@ (nn-send repsoc (db:obj->string result transport: 'nmsg))) (loop (nn-recv repsoc)))))) ;; all routes though here end in exit ... ;; -(define (nmsg-transport:launch run-id) +(define (nmsg-transport:launch run-id area-dat) (let* ((tdbdat (tasks:open-db)) (dbstruct (db:setup run-id)) (hostn (or (args:get-arg "-server") "-"))) (set! *run-id* run-id) (set! *inmemdb* dbstruct) @@ -142,11 +142,11 @@ ;; since we didn't get the server lock we are going to clean up and bail out (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") )) ;; locked in a server id, try to start up - (nmsg-transport:run dbstruct hostn run-id server-id)) + (nmsg-transport:run dbstruct area-dat hostn run-id server-id)) (set! *didsomething* #t) (exit)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S @@ -252,11 +252,11 @@ (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) ;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; -(define (nmsg-transport:keep-running server-id run-id) +(define (nmsg-transport:keep-running server-id run-id area-dat) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (let* ((server-info (let loop () (let ((sdat #f)) @@ -272,11 +272,11 @@ (loop)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (tdbdat (tasks:open-db)) - (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) + (server-timeout (let ((tmo (configf:lookup (megatest:area-configdat area-dat) "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days (* 60 1) ;; default to one minute Index: olddashboard.scm ================================================================== --- olddashboard.scm +++ olddashboard.scm @@ -351,11 +351,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:attribute-set! keys-matrix "WIDTHDEF" "40") keys-matrix)) ;; Section to table @@ -377,11 +377,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:vbox (iup:label (if title title (conc "Settings from [" sectionname "]")) ;; #:size "5x" #:expand "HORIZONTAL" @@ -403,11 +403,11 @@ ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area ;; (iup:attribute-set! general-matrix "2:0" "Area") - ;; (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; (iup:attribute-set! general-matrix "2:1" toppath) ;; Megatest version (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) @@ -756,11 +756,11 @@ (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. @@ -824,11 +824,11 @@ (set! *tests-sort-reverse* 0) (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) *tests-sort-reverse*) (define *tests-sort-reverse* - (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) + (let ((t-sort (assoc (configf:lookup (megatest:area-configdat *area-dat*) "dashboard" "testsort") *tests-sort-type-index*))) (if t-sort (cadr t-sort) 3))) (define (get-curr-sort) @@ -1384,11 +1384,11 @@ ;; A gui for launching tests ;; (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) - (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests toppath '())) (test-names (hash-table-keys all-tests-registry)) (sorted-testnames #f) (action "-runtests") (cmdln "") (runlogs (make-hash-table)) @@ -1646,21 +1646,22 @@ ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area -(define (dashboard:summary db) - (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) +(define (dashboard:summary db area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (rawconfig (read-config (conc toppath "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (iup:vbox (iup:split #:value 500 (iup:frame #:title "General Info" (iup:vbox (iup:hbox (iup:label "Area Path") - (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) + (iup:textbox #:value toppath #:expand "HORIZONTAL")) (iup:hbox (dcommon:keys-matrix rawconfig) (dcommon:general-info) ))) (iup:frame @@ -1850,12 +1851,13 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (make-dashboard-buttons db nruns ntests keynames) - (let* ((nkeys (length keynames)) +(define (make-dashboard-buttons db nruns ntests keynames area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) (controls '()) @@ -2060,11 +2062,11 @@ (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog - #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) + #:title (conc "Megatest dashboard " (current-user-name) ":" toppath) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (apply iup:hbox (cons (apply iup:vbox lftlst) (list @@ -2105,11 +2107,11 @@ (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; -(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) +(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc toppath "/db/main.db"))) (define *last-recalc-ended-time* 0) (define (dashboard:been-changed) (> (file-modification-time *db-file-path*) *last-db-update-time*)) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -114,12 +114,12 @@ (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) -(define (portlogger:find-port db) - (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) +(define (portlogger:find-port db area-dat) + (let* ((lowport (let ((val (configf:lookup (megatest:area-configdat area-dat) "server" "lowport"))) (if (and val (string->number val)) (string->number val) 32768))) (portnum (or (portlogger:get-prev-used-port db) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -93,11 +93,11 @@ (if (and (vector? connection) (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") ;; SHOULD CLOSE THE CONNECTION HERE - (case *transport-type* + (case (megatest:area-transport area-dat) ((nmsg)(nn-close (http-transport:server-dat-get-socket (common:get-remote remote run-id))))) (common:del-remote! remote run-id))))) (common:get-remote-all remote))) (mutex-unlock! *db-multi-sync-mutex*)) @@ -106,10 +106,11 @@ (define (rmt:send-receive cmd rid params area-dat #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected (rmt:discard-old-connections area-dat) ;; (mutex-lock! *send-receive-mutex*) (let* ((run-id (if rid rid 0)) + (configdat (megatest:area-configdat area-dat)) (connection-info (rmt:get-connection-info run-id area-dat))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info ;; use the server if have connection info (let* ((dat (case *transport-type* @@ -153,11 +154,11 @@ ;; ;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call ;; (if (and (< attemptnum 15) (member cmd api:write-queries)) - (let ((faststart (configf:lookup *configdat* "server" "faststart"))) + (let ((faststart (configf:lookup configdat "server" "faststart"))) (common:del-remote! remote run-id) ;; (mutex-unlock! *send-receive-mutex*) (if (and faststart (equal? faststart "no")) (begin (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) @@ -191,11 +192,11 @@ (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) (mutex-unlock! *db-stats-mutex*)) -(define (rmt:print-db-stats) +(define (rmt:print-db-stats area-dat) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 "DB Stats\n========") (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) @@ -231,11 +232,11 @@ res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((dbstruct-local (if *dbstruct-db* *dbstruct-db* - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (let* ((dbdir (db:dbfile-path #f)) (db (make-dbr:dbstruct path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) @@ -310,20 +311,22 @@ ;;====================================================================== ;; M I S C ;;====================================================================== -(define (rmt:login run-id) - (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat)) +(define (rmt:login run-id area-dat) + (rmt:send-receive 'login run-id (list (megatest:area-path area-dat) megatest-version run-id *my-client-signature*) area-dat)) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; -(define (rmt:login-no-auto-client-setup connection-info run-id) - (case *transport-type* - ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat)) - ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*) area-dat)))) +(define (rmt:login-no-auto-client-setup connection-info run-id area-dat) + (let ((transport (megatest:area-transport area-dat)) + (toppath (megatest:area-path area-dat))) + (case transport + ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list toppath megatest-version run-id *my-client-signature*) area-dat)) + ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list toppath megatest-version run-id *my-client-signature*) area-dat))))) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id area-dat . params) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -61,26 +61,27 @@ (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch"))) (begin (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) (exit))))) -(define (rpc-transport:run hostn run-id server-id) +(define (rpc-transport:run hostn run-id server-id area-dat) (debug:print 2 "Attempting to start the rpc server ...") ;; (trace rpc:publish-procedure!) (rpc:publish-procedure! 'server:login server:login) (rpc:publish-procedure! 'testing (lambda () "Just testing")) - (let* ((db #f) + (let* ((configdat (megatest:area-configdat area-dat)) + (db #f) (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (open-run-close tasks:server-get-next-port tasks:open-db)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (link-tree-path (configf:lookup configdat "setup" "linktree")) (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) (th1 (make-thread (lambda () ((rpc:make-server rpc:listener) #t)) "rpc:server")) @@ -143,63 +144,64 @@ (rpc-transport:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) (tcp-read-timeout 240000) (tcp-listen (rpc:default-server-port) 10000))) -(define (rpc-transport:ping run-id host port) +(define (rpc-transport:ping run-id host port area-dat) (handle-exceptions exn (begin (print "SERVER_NOT_FOUND") (exit 1)) - (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) + (let ((login-res ((rpc:procedure 'server:login host port) (megatest:area-path area-dat)))) (if (and (list? login-res) (car login-res)) (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1)))))) -(define (rpc-transport:client-setup run-id #!key (remtries 10)) +(define (rpc-transport:client-setup run-id area-dat #!key (remtries 10)) (if (common:get-remote remote run-id) (begin (debug:print 0 "ERROR: Attempt to connect to server but already connected") #f) - (let* ((host-info (common:get-remote remote run-id))) ;; (open-run-close db:get-var #f "SERVER")) + (let* ((toppath (megatest:area-path area-dat)) + (host-info (common:get-remote remote run-id))) ;; (open-run-close db:get-var #f "SERVER")) (if host-info (let ((iface (car host-info)) (port (cadr host-info)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) + (ping-res ((rpc:procedure 'server:login host port) toppath))) (if ping-res (let ((server-dat (list iface port #f #f #f))) (common:set-remote! remote run-id server-dat) server-dat) (begin (server:try-running run-id) (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) + (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1))))) (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-db-info (let* ((iface (tasks:hostinfo-get-interface server-db-info)) (port (tasks:hostinfo-get-port server-db-info)) (server-dat (list iface port #f #f #f)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) + (ping-res ((rpc:procedure 'server:login host port) toppath))) (if start-res (begin (common:set-remote! remote run-id server-dat) server-dat) (begin (server:try-running run-id) (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) + (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1))))) (begin (server:try-running run-id) (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))))))) + (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1))))))))) ;; ;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) ;; (if (and port ;; (string->number port)) ;; (let ((portn (string->number port))) @@ -213,14 +215,14 @@ ;; ;; (lambda (db . param) ;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) ;; ;; #f) ;; (set! (common:get-remote remote) #f)) ;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server -;; ((rpc:procedure 'server:login host portn) *toppath*)) +;; ((rpc:procedure 'server:login host portn) toppath)) ;; (begin ;; (debug:print-info 2 "Logged in and connected to " host ":" port) ;; (set! (common:get-remote remote) (vector host portn))) ;; (begin ;; (debug:print-info 2 "Failed to login or connect to " host ":" port) ;; (set! (common:get-remote remote) #f))))) ;; (debug:print-info 2 "no server available"))))) Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2015, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -19,11 +19,11 @@ (define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config (define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config (define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) (define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http (define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) -(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* +(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; toppath (define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id (define-inline (test:get-id vec) (vector-ref vec 0)) (define-inline (test:get-run_id vec) (vector-ref vec 1)) (define-inline (test:get-test-name vec)(vector-ref vec 2)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -56,13 +56,13 @@ sections) (debug:print 2 "---") (set! *already-seen-runconfig-info* #t))) finaldat)) -(define (set-run-config-vars run-id keyvals targ-from-db) - (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... - (let ((runconfigf (conc *toppath* "/runconfigs.config")) +(define (set-run-config-vars run-id keyvals targ-from-db area-dat) + (push-directory (megatest:area-path area-dat)) ;; the push/pop doesn't appear to do anything ... + (let ((runconfigf (conc (megatest:area-path area-dat) "/runconfigs.config")) (targ (or (common:args-get-target) targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -36,15 +36,17 @@ (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) ;;;;;; ;; This is the *new* methodology. One record to inform them and in the chaos, organise them. ;;;;;; ;; ;;;;;; (define (runs:create-run-record area-dat) ;; #!key (remote #f)) -;;;;;; (let* ((remote (megatest:area-remote area-dat)) -;;;;;; (mconfig (if *configdat* -;;;;;; *configdat* +;;;;;; (let* ((remote (megatest:area-remote area-dat)) +;;;;;; (configdat (megatest:area-configdat area-dat)) +;;;;;; (toppath (megatest:area-path area-dat))) +;;;;;; (mconfig (if configdat +;;;;;; configdat ;;;;;; (if (launch:setup-for-run) -;;;;;; *configdat* +;;;;;; configdat ;;;;;; (begin ;;;;;; (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") ;;;;;; (exit 1))))) ;;;;;; (runrec (runs:runrec-make-record)) ;;;;;; (target (common:args-get-target)) @@ -52,11 +54,10 @@ ;;;;;; (args:get-arg ":runname"))) ;;;;;; (testpatt (or (args:get-arg "-testpatt") ;;;;;; (args:get-arg "-runtests"))) ;;;;;; (keys (keys:config-get-fields mconfig)) ;;;;;; (keyvals (keys:target->keyval keys target)) -;;;;;; (toppath *toppath*) ;;;;;; (envdat keyvals) ;; initial values start with keyvals ;;;;;; (runconfig #f) ;;;;;; (transport (or (args:get-arg "-transport") 'http)) ;;;;;; (run-id #f)) ;;;;;; ;; Set all the environment vars we know so far, start with keys @@ -73,11 +74,11 @@ ;;;;;; (list (list "MT_RUN_AREA_HOME" toppath) ;;;;;; (list "MT_RUNNAME" runname) ;;;;;; (list "MT_TARGET" target)))) ;;;;;; ;; Now can read the runconfigs file ;;;;;; ;; -;;;;;; (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) +;;;;;; (set! runconfig (read-config (conc toppath "/runconfigs.config") #f #t sections: (list "default" target))) ;;;;;; (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) ;;;;;; (begin ;;;;;; (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) ;;;;;; (if db (sqlite3:finalize! db)) ;;;;;; (exit 1))) @@ -90,10 +91,11 @@ ;;;;;; (list "default" target)) ;;;;;; (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id))) (define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) (target (or (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) @@ -121,11 +123,11 @@ ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print 0 "ERROR: no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*))) + (setenv "MT_RUN_AREA_HOME" toppath))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) @@ -222,11 +224,11 @@ (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db))) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) (set-signal-handler! signal/int (lambda (signum) (signal-mask! signum) (print "Received signal " signum ", cleaning up before exit. Please wait...") @@ -236,26 +238,26 @@ (exit))) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") - (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; Now generate all the tests lists - (set! all-tests-registry (tests:get-all)) + (set! all-tests-registry (tests:get-all area-dat)) (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat)) + ;; (set! test-names (delete-duplicates (tests:get-valid-tests toppath test-patts))) + (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat area-dat)) (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified @@ -288,11 +290,11 @@ ;; ;;====================================================================== (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. + (change-directory toppath) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (setenv "MT_TEST_NAME" hed) ;; (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test @@ -515,11 +517,11 @@ (null? non-completed))) (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) (let ((test-id (rmt:get-test-id run-id test-name ""))) @@ -760,11 +762,11 @@ (set! *max-tries-hash* (make-hash-table)) ;; well, first lets see if cpu load throttling is enabled. If so wait around until the ;; average cpu load is under the threshold before continuing (if (configf:lookup configdat "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry area-dat) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) @@ -967,11 +969,11 @@ (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id area-dat))) ;; every couple minutes verify the server is there for this run (if (and (common:low-noise-print 60 "try start server" run-id) - (tasks:need-server run-id)) + (tasks:need-server run-id area-dat)) (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood (if (> num-running 0) (set! last-time-some-running (current-seconds))) @@ -1202,17 +1204,18 @@ (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry area-dat) ;; All these vars might be referenced by the testconfig file reader - (let* ((test-name (tests:testqueue-get-testname test-record)) + (let* ((toppath (megatest:area-path area-dat)) + (test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) - (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + (test-path (hash-table-ref all-tests-registry test-name)) (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x"))) (item-path "") @@ -1230,12 +1233,12 @@ ) (debug:print 2 "Attempting to launch test " full-test-name) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_ITEMPATH" item-path) (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process - (change-directory *toppath*) + (runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process + (change-directory toppath) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; ;; There is now a single call to runs:update-all-test_meta and this @@ -1279,11 +1282,11 @@ (set! test-id (db:test-get-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") - (change-directory *toppath*))) + (change-directory toppath))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) @@ -1463,18 +1466,18 @@ (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here (if (equal? testpatt "%") (tasks:kill-runner target run-name) (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) @@ -1755,11 +1758,11 @@ (rmt:testmeta-update-field test-name fld val area-dat))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) + (let ((test-names (tests:get-all area-dat))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) (if test-conf (runs:update-test_meta test-name test-conf)))) (hash-table-keys test-names)))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -47,15 +47,15 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; -(define (server:launch run-id) +(define (server:launch run-id area-dat) (case *transport-type* - ((http)(http-transport:launch run-id)) - ((nmsg)(nmsg-transport:launch run-id)) - ((rpc) (rpc-transport:launch run-id)) + ((http)(http-transport:launch run-id area-dat)) + ((nmsg)(nmsg-transport:launch run-id area-dat)) + ((rpc) (rpc-transport:launch run-id area-dat)) (else (debug:print 0 "ERROR: unknown server type " *transport-type*)))) ;; (else (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) ;;====================================================================== @@ -232,14 +232,14 @@ ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) -(define (server:login toppath) +(define (server:login toppath area-dat) (lambda (toppath) (set! *last-db-access* (current-seconds)) - (if (equal? *toppath* toppath) + (if (equal? (megatest:area-path area-dat) toppath) (begin ;; (debug:print-info 2 "login successful") #t) (begin ;; (debug:print-info 2 "login failed") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -90,11 +90,11 @@ (dbpath (tasks:get-task-db-path area-dat)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) - (mdb (cond ;; what the hek is *toppath* doing here? + (mdb (cond ;; what the hek is toppath doing here? ((and (string? toppath)(file-write-access? toppath)) (sqlite3:open-database dbfile)) ((file-read-access? dbpath) (sqlite3:open-database dbfile)) (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) @@ -102,11 +102,11 @@ (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) - ;; (file-write-access? *toppath*)) + ;; (file-write-access? toppath)) ;; (not (file-read-access? dbpath))) ;; (begin ;; ;; TASKS QUEUE MOVED TO main.db ;; @@ -254,16 +254,11 @@ (get-rand-port (lambda () (+ lownum (random (- highnum lownum))))) (port-param (if (and (args:get-arg "-port") (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) - #f)) - ;; (config-port (if (and (config-lookup *configdat* "server" "port") - ;; (string->number (config-lookup *configdat* "server" "port"))) - ;; (string->number (config-lookup *configdat* "server" "port")) - ;; #f)) - ) + #f))) (sqlite3:for-each-row (lambda (port) (set! used-ports (cons port used-ports))) mdb "SELECT port FROM servers;") @@ -361,15 +356,19 @@ (set! res id)) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) -(define (tasks:need-server run-id) - (configf:lookup *configdat* "server" "required")) +(define (tasks:need-server run-id area-dat) + (let ((req (configf:lookup (megatest:area-configdat area-dat) "server" "required"))) + (if (and req + (equal? req "yes")) + #t + #f))) ;; (maxqry (cdr (rmt:get-max-query-average run-id))) -;; (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) +;; (threshold (string->number (or (configf:lookup configdat "server" "server-query-threshold") "10")))) ;; (cond ;; (forced ;; (if (common:low-noise-print 60 run-id "server required is set") ;; (debug:print-info 0 "Server required is set, starting server for run-id " run-id ".")) ;; #t) @@ -512,31 +511,10 @@ mdb "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) -;; -(define (tasks:start-monitor db mdb) - (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more - (debug:print-info 1 "Not starting monitor, already have more than two running") - (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) - (last-db-update 0)) ;; (file-modification-time megatestdb))) - (task:register-monitor mdb) - (let loop ((count 0) - (next-touch 0)) ;; next-touch is the time where we need to update last_update - ;; if the db has been modified we'd best look at the task queue - (let ((modtime (file-modification-time megatestdbpath ))) - (if (> modtime last-db-update) - (tasks:process-queue db mdb last-db-update megatestdb next-touch)) - ;; WARNING: Possible race conditon here!! - ;; should this update be immediately after the task-get-action call above? - (if (> (current-seconds) next-touch) - (begin - (tasks:monitors-update mdb) - (loop (+ count 1)(+ (current-seconds) 240))) - (loop (+ count 1) next-touch))))))) ;;====================================================================== ;; T A S K S Q U E U E ;; ;; NOTE:: These operate on task_queue which is in main.db Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -32,17 +32,17 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests -(define (tests:get-all) - (let* ((test-search-path (tests:get-tests-search-path *configdat*))) +(define (tests:get-all area-dat) + (let* ((test-search-path (tests:get-tests-search-path (megatest:area-configdat area-dat)))) (tests:get-valid-tests (make-hash-table) test-search-path))) -(define (tests:get-tests-search-path cfgdat) +(define (tests:get-tests-search-path cfgdat area-dat) (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) - (append paths (list (conc *toppath* "/tests"))))) + (append paths (list (conc (megatest:area-path area-dat) "/tests"))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) test-registry (let loop ((hed (car tests-paths)) @@ -584,12 +584,12 @@ ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) -(define (tests:get-testconfig test-name test-registry system-allowed) - (let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name))) +(define (tests:get-testconfig test-name test-registry system-allowed area-dat) + (let* ((test-path (hash-table-ref/default test-registry test-name (conc (megatest:area-path area-dat) "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -66,13 +66,13 @@ (define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) (define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) (define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) (define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) -(define (zmq-transport:run hostn) +(define (zmq-transport:run hostn area-dat) (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) + (if (not (megatest:area-path area-dat)) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") (exit)))) (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db @@ -109,11 +109,11 @@ (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of (common:get-remote remote) BUG!? ;; what to do when we quit ;; ;; (on-exit (lambda () -;; (if (and *toppath* *server-info*) +;; (if (and toppath *server-info*) ;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) ;; (let loop () ;; (let ((queue-len 0)) ;; (thread-sleep! (random 5)) ;; (mutex-lock! *incoming-mutex*) @@ -359,18 +359,18 @@ (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) ;; all routes though here end in exit ... -(define (zmq-transport:launch) - (if (not *toppath*) - (if (not (setup-for-run)) +(define (zmq-transport:launch run-id area-dat) + (if (not (megatest:area-path area-dat)) + (if (not (launch:setup-for-run area-dat)) (begin (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting zmq server") - (if *toppath* + (if (megatest:area-path area-dat) (let* (;; (th1 (make-thread (lambda () ;; (let ((server-info #f)) ;; ;; wait for the server to be online and available ;; (let loop () ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat")