Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -38,11 +38,12 @@ ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut +# ndboard mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm @@ -234,13 +235,13 @@ install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ - $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt + $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/tcmt -# $(PREFIX)/bin/newdashboard +# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -701,11 +701,11 @@ #t ;; data is good. (begin (handle-exceptions exn #f - (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (debug:print 0 *default-log-port* "WARNING: content read from cache " fname " is not readable. Deleting generated file.") (delete-file fname)) #f)) #f)))) (common:faux-unlock fname) res)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -412,10 +412,31 @@ (or new-cpu-load cpu-load) (or new-disk-free disk-free) (if do-sync (current-seconds) last-sync))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional +(define (launch:test-execute-exit-handler run-id test-id) + (let ((sighand (lambda (signum) + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + (if (eq? signum signal/stop) + (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) + (set! *time-to-exit* #t) + (print "Received signal " signum ", cleaning up before exit. Please wait...") + (let ((th1 (make-thread (lambda () + (rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f) + (print "Killed by signal " signum ". Exiting") + (thread-sleep! 1) + (exit 1)))) + (th2 (make-thread (lambda () + (thread-sleep! 2) + (debug:print 0 *default-log-port* "Done") + (exit 4))))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2))))) + (set-signal-handler! signal/int sighand) + (set-signal-handler! signal/term sighand))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) @@ -422,11 +443,11 @@ ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area + (work-area #f) ;; (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) ;; (transport (assoc/default 'transport cmdinfo)) ;; not used @@ -446,11 +467,11 @@ (runtlim (assoc/default 'runtlim cmdinfo)) (contour (assoc/default 'contour cmdinfo)) (item-path (item-list->path itemdat)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) - (keyvals #f) + ;; (keyvals (assoc/default 'keyvals cmdinfo)) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc testpath "/" runscript))) @@ -465,60 +486,11 @@ ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; (setenv "MT_TESTSUITENAME" areaname) (setenv "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) - (setenv "MT_TEST_RUN_DIR" work-area) - - ;; ;; On NFS it can be slow and unreliable to get needed startup information. - ;; ;; i. Check if we are on the homehost, if so, proceed - ;; ;; ii. Check if host and port passed in via CMDINFO are valid and if - ;; ;; possible use them. - ;; (let ((bestadrs (server:get-best-guess-address (get-host-name))) - ;; (needcare #f)) - ;; (if (equal? homehost bestadrs) ;; we are likely on the homehost - ;; (debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost) - ;; (let ((host-port (if serverurl (string-split serverurl ":") #f))) - ;; (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote* - ;; (if (string? homehost) - ;; (if (and host-port - ;; (> (length host-port) 1)) - ;; (let* ((host (car host-port)) - ;; (port (cadr host-port)) - ;; (start-res (http-transport:client-connect host port)) - ;; (ping-res (rmt:login-no-auto-client-setup start-res))) - ;; (if (and start-res - ;; ping-res) - ;; ;; (begin ;; let ((url (http-transport:server-dat-make-url start-res))) - ;; (begin - ;; (remote-conndat-set! *runremote* start-res) - ;; ;; (remote-server-url-set! *runremote* url) - ;; ;; (if (server:ping url) - ;; (debug:print-info 0 *default-log-port* "connected to " host ":" port " using CMDINFO data.")) - ;; (begin - ;; (debug:print-info 0 *default-log-port* "have CMDINFO data but failed to connect to " host ":" port) - ;; (set! *runremote* #f)) - ;; ;; (remote-conndat-set! *runremote* #f)) - ;; )) - ;; (begin - ;; (set! *runremote* #f) - ;; (debug:print-info 0 *default-log-port* (if host-port - ;; (conc "received invalid host-port information " host-port) - ;; "no host-port information received")) - ;; ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare. - ;; (set! needcare #t))) - ;; (begin - ;; (set! *runremote* #f) - ;; (debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.") - ;; (set! needcare #t))))) - ;; (if needcare ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host - ;; (let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory - ;; (handle-exceptions - ;; exn - ;; (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (create-directory logdir #t))))) - ;; + ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (common:file-exists? top-path) (> count 10)) (change-directory top-path) @@ -526,32 +498,13 @@ (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") (thread-sleep! 10) (loop (+ count 1))))) (launch:setup) ;; should be properly in the top-path now (set! tconfigreg (tests:get-all)) - (let ((sighand (lambda (signum) - ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting - (if (eq? signum signal/stop) - (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) - (set! *time-to-exit* #t) - (print "Received signal " signum ", cleaning up before exit. Please wait...") - (let ((th1 (make-thread (lambda () - (rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f) - (print "Killed by signal " signum ". Exiting") - (thread-sleep! 1) - (exit 1)))) - (th2 (make-thread (lambda () - (thread-sleep! 2) - (debug:print 0 *default-log-port* "Done") - (exit 4))))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2))))) - (set-signal-handler! signal/int sighand) - (set-signal-handler! signal/term sighand) - ) ;; (set-signal-handler! signal/stop sighand) - + + (launch:test-execute-exit-handler run-id test-id) + ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) (test-host (if test-info @@ -558,10 +511,15 @@ (db:test-get-host test-info) (begin (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.") (exit)))) (test-pid (db:test-get-process_id test-info))) + + + ;; was here + + (cond ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) @@ -612,18 +570,19 @@ (configf:get-section rconfig section))) (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed - (let loop ((count 0)) - (if (or (common:file-exists? work-area) - (> count 10)) - (change-directory work-area) - (begin - (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") - (thread-sleep! 10) - (loop (+ count 1))))) + ;; (let loop ((count 0)) + ;; (if (or (common:file-exists? work-area) + ;; (> count 10)) + ;; (change-directory work-area) + ;; (begin + ;; (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") + ;; (thread-sleep! 10) + ;; (loop (+ count 1))))) + ;;(bb-check-path msg: "launch:execute post block 1.5") ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config @@ -647,11 +606,11 @@ (setenv var val) (begin (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") (exit))))) (list - (list "MT_TEST_RUN_DIR" work-area) + ;; (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) @@ -672,10 +631,19 @@ ;;(bb-check-path msg: "launch:execute post block 41") (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;;(bb-check-path msg: "launch:execute post block 42") (set-item-env-vars itemdat) ;;(bb-check-path msg: "launch:execute post block 43") + + ;; we have deferred creating the work-area as far as possible. have to do it now + (let ((dat (create-work-area run-id runname target test-id testpath #f test-name itemdat tregistery: tconfigreg))) + (set! work-area (car dat))) + (debug:print-info 2 *default-log-port* "Using work area " work-area) + + (setenv "MT_TEST_RUN_DIR" work-area) + (change-directory work-area) + (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) (if blacklist (save-environment-as-files "megatest" ignorevars: (string-split blacklist)) (save-environment-as-files "megatest"))) ;;(bb-check-path msg: "launch:execute post block 44") @@ -1059,25 +1027,27 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) +(define (create-work-area run-id run-info target test-id test-src-path disk-path-in test-name itemdat #!key (tconfig #f)(remtries 2)(tregistery #f)) (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it + (testconf (or tconfig (tests:forced-get-testconfig test-name item-path))) ;; (tests:get-testconfig test-name item-path (or tregistery (make-hash-table)) #t force-create: #t))) + (disk-path (if disk-path-in disk-path-in (get-best-disk *configdat* tconfig))) ;; NOTE: You'd better have tconfig defined! (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. run-info (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) ;; convert back to db: from rdb: - this is always run at server end - (target (string-intersperse (map cadr keyvals) "/")) + ;; (target (string-intersperse (map cadr keyvals) "/")) (not-iterated (equal? "" item-path)) ;; all tests are found at /test-base or /test-base - (testtop-base (conc target "/" runname "/" testname)) + (testtop-base (conc target "/" runname "/" test-name)) (test-base (conc testtop-base (if not-iterated "" "/") item-path)) ;; nb// if itempath is not "" then it is prefixed with "/" (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) @@ -1087,17 +1057,17 @@ ;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree"))) ;; (if rd rd (conc *toppath* "/runs")))) ;; which seems wrong ... (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) - (lnkpath (conc lnkbase "/" testname)) + (lnkpath (conc lnkbase "/" test-name)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical ;; rundir shortdir - (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path test-name item-path run-id) (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (common:file-exists? linktree)) (begin (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) @@ -1152,35 +1122,35 @@ ;; ;; Do the setting of this record after the paths are created so that the shortdir can ;; be set to the real directory location. This is safer for future clean up if the link ;; tree is damaged or lost. ;; - (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (if (not (hash-table-ref/default *toptest-paths* test-name #f)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id test-name item-path)) (curr-test-path (if testinfo ;; (filedb:get-path *fdb* ;; (db:get-path dbstruct ;; (rmt:sdb-qry 'getstr (db:test-get-rundir testinfo) ;; ) ;; ) #f))) - (hash-table-set! *toptest-paths* testname curr-test-path) + (hash-table-set! *toptest-paths* test-name curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (common:file-exists? lnkpath) ;; (resolve-pathname lnkpath) (common:nice-path lnkpath) lnkpath) - testname "" run-id) - ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) + test-name "" run-id) + ;; (rmt:general-call 'test-set-rundir run-id lnkpath test-name "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) (handle-exceptions exn #f ;; don't care to catch and deal with errors here for now. (create-directory toptest-path #t)) - (hash-table-set! *toptest-paths* testname toptest-path))))) + (hash-table-set! *toptest-paths* test-name toptest-path))))) ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) @@ -1226,36 +1196,23 @@ (list lnkpathf lnkpath )) (if (and test-src-path (> remtries 0)) (begin (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; - (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) + (create-work-area run-id run-info target test-id test-src-path disk-path-in test-name itemdat remtries: (- remtries 1))) (list #f #f))))) ;; 1. look though disks list for disk with most space ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) -(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) +(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-source-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex - (let* ( ;; (lock-key (conc "test-" test-id)) - ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key)) - ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds - ;; (if (car lock) - ;; #t - ;; (if (> (current-seconds) expire-time) - ;; (begin - ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path) - ;; (rmt:no-sync-del! lock-key) ;; destroy the lock - ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;; - ;; (begin - ;; (thread-sleep! 1) - ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) - (item-path (item-list->path itemdat)) + (let* ((item-path (item-list->path itemdat)) (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 1))) (if (> launch-delay delta) (begin @@ -1306,21 +1263,35 @@ ((dboard) "../megatest") ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher")) - (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path + (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-source-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all - (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) - (if (args:get-arg "-logging")(list "-logging") '())))) + (if (args:get-arg "-logging")(list "-logging") '()))) + (log-path-1 (conc *toppath* "/lt/" mt_target "/" runname)) ;; (string-intersperse (map cadr keyvals) "/")) + (log-path-2 (conc *toppath* "/lt/" mt_target "/" runname "/" test-name)) + (log-file (conc (cond + ((and (file-write-access? log-path-2)(directory? log-path-2)(not (symbolic-link? log-path-2))) log-path-2) + ((and (file-write-access? log-path-1)(directory? log-path-1)) log-path-1) + (else + (debug:print 0 *default-log-port* "INFO: path \"" log-path-1 "\" and \"" log-path-2 "\" not available to write output to. Directing output to logs dir.") + (conc *toppath* "/logs/"))) + (string-intersperse (map cadr keyvals) "-") "-" + runname "-" + test-name + (if (null? itemdat) + (conc "-" (string-intersperse (map cdr itemdat) "-")) + "") + ".log"))) ;; (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) @@ -1335,25 +1306,20 @@ ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) ;; (pp (hash-table->alist tconfig)) - (set! diskpath (get-best-disk *configdat* tconfig)) - (if diskpath - (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) - (set! work-area (car dat)) - (set! toptest-work-area (cadr dat)) - (debug:print-info 2 *default-log-port* "Using work area " work-area)) - (begin - (set! work-area (conc test-path "/tmp_run")) - (create-directory work-area #t) - (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) +;;(if (configf:var-is? *configdat* "setup" "early-setup" "yes") +;; (let ((dat (create-work-area run-id run-info keyvals test-id test-source-path #f test-name itemdat tconfig: tconfig))) +;; (set! work-area (car dat)) +;; (set! toptest-work-area (cadr dat)) +;; (debug:print-info 2 *default-log-port* "Using work area " work-area))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) - (write (list (list 'testpath test-path) + (write (list (list 'testpath test-source-path) ;; (list 'transport (conc *transport-type*)) ;; (list 'serverinf *server-info*) (list 'homehost (let* ((hhdat (common:get-homehost))) (if hhdat (car hhdat) @@ -1361,11 +1327,11 @@ (list 'serverurl (if *runremote* (remote-server-url *runremote*) #f)) ;; (list 'areaname (common:get-testsuite-name)) (list 'toppath *toppath*) - (list 'work-area work-area) + ;; (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) (list 'test-id test-id ) ;; (list 'item-path item-path ) @@ -1372,21 +1338,25 @@ (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'target mt_target) (list 'contour contour) + ;; (list 'keyvals keyvals) (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) - (list 'mt-bindir-path mt-bindir-path)))))))) + (list 'mt-bindir-path mt-bindir-path) + (list 'log-file log-file)))))))) ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway - (if (common:file-exists? work-area) - (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir + + ;; (if (and work-area (common:file-exists? work-area)) + ;; (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir + (cond ;; ((and launcher hosts) ;; must be using ssh hostname ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher @@ -1395,23 +1365,24 @@ (else (if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" "")))))) ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) - (debug:print 1 *default-log-port* "Launching " work-area) + ;; (debug:print 1 *default-log-port* "Launching " work-area) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 *default-log-port* "fullcmd: " fullcmd) (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible. (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" - (append (list (list "MT_TEST_RUN_DIR" work-area) + (append (list ;; (list "MT_TEST_RUN_DIR" (if work-area work-area "no-test-run-area-set-yet")) (list "MT_TEST_NAME" test-name) - (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_ITEM_INFO" (conc itemdat)) ;; GET RID OF THIS ONE (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) (list "MT_ITEMPATH" item-path) + (list "MT_LAUNCH_LOGF" log-file) ) itemdat))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) ;; Launchwait defaults to true, must override it to turn off wait @@ -1421,20 +1392,20 @@ process-run) (if useshell (let ((cmdstr (string-intersperse fullcmd " "))) (if launchwait cmdstr - (conc cmdstr " >> mt_launch.log 2>&1 &"))) + (conc cmdstr " >> " log-file " 2>&1 &"))) (car fullcmd)) (if useshell '() (cdr fullcmd))))) (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) - (with-output-to-file "mt_launch.log" + (with-output-to-file log-file ;; "mt_launch.log" (lambda () (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) (if (list? launch-results) (apply print launch-results) (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1705,11 +1705,11 @@ ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) + ;; (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) @@ -1817,24 +1817,27 @@ (begin (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) ;; the test source area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) - (db #f)) - (change-directory testpath) + ;; (work-area (assoc/default 'work-area cmdinfo)) ;; the test run area, no longer available from cmdinfo + (db #f) + (work-area #f)) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) + (set! work-area (db:test-get-rundir testdat))) + (change-directory work-area) ;; why would this have ever been testpath? Makes no sense (if (and state status) (let ((comment (launch:load-logpro-dat run-id test-id step))) ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin @@ -1866,28 +1869,30 @@ (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) ;; source area for test files (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) + ;; (work-area (assoc/default 'work-area cmdinfo)) ;; the area where the test runs, no longer available from cmdinfo (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) - (stepname (args:get-arg "-step"))) + (stepname (args:get-arg "-step")) + (work-area #f)) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) + (set! work-area (db:test-get-rundir testdat))) (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -1207,11 +1207,39 @@ (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (not (common:in-running-test?)) (configf:write-alist tcfg tpath)))) tcfg)))))) - + +;; forced read and write of cache of testconfig for the exection of the test +;; +(define (tests:forced-get-testconfig test-name item-path) + (let* ((cache-path (tests:get-test-path-from-environment)) + (cache-file (and cache-path (conc cache-path "/.testconfig"))) + (test-full-name (if (and item-path (not (string-null? item-path))) + (conc test-name "/" item-path) + test-name))) + ;; no cached data available + (let* ((treg (tests:get-all)) ;; we need the tests info from all the possible tests paths + (test-path (or (hash-table-ref/default treg test-name #f) + (conc *toppath* "/tests/" test-name))) + (test-configf (conc test-path "/testconfig")) + (testexists (file-read-access? test-configf)) + (tcfg (if testexists + (read-config test-configf #f #t ;; system-allowed + environ-patt: "pre-launch-env-vars" + ) + #f))) + (if tcfg (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data + (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) + (if (and testexists + (file-write-access? cache-path)) + (let ((tpath (conc cache-path "/.testconfig"))) + (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) + (configf:write-alist tcfg tpath))) + tcfg))) + ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (if (eq? (hash-table-size test-records) 0) '()