Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -52,10 +52,44 @@ csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard mtut: $(OFILES) mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut +TCMTOBJS = \ + api.o \ + archive.o \ + cgisetup/models/pgdb.o \ + client.o \ + common.o \ + configf.o \ + daemon.o \ + db.o \ + env.o \ + http-transport.o \ + items.o \ + keys.o \ + launch.o \ + lock-queue.o \ + margs.o \ + mt.o \ + megatest-version.o \ + ods.o \ + portlogger.o \ + process.o \ + rmt.o \ + rpc-transport.o \ + runconfig.o \ + runs.o \ + server.o \ + tasks.o \ + tdb.o \ + tests.o \ + + +tcmt : $(TCMTOBJS) tcmt.scm + csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt + # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html mkdir -p $(PREFIX)/share/docs @@ -114,10 +148,17 @@ $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil + +$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt + $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt + +$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper + utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt + chmod a+x $(PREFIX)/bin/tcmt # $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard # $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard # $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper @@ -193,11 +234,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/newdashboard + $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt + +# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -195,10 +195,15 @@ ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -108,10 +108,12 @@ (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) +;; no sync db +(define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold @@ -237,11 +239,11 @@ (not (equal? (common:get-last-run-version) (common:version-signature)))) (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) - (substring (common:get-last-run-version) 0 4)))) + (substring (conc (common:get-last-run-version)) 0 4)))) ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct) @@ -1076,11 +1078,11 @@ ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation - (if *configdat* + (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") (set! res #f) (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") (set! res #t)))) (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" @@ -2064,21 +2066,29 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) -(define (common:faux-lock keyname) - (if (rmt:get-var keyname) - #f +(define (common:faux-lock keyname #!key (wait-time 8)) + (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count + (if (> wait-time 0) + (begin + (thread-sleep! 1) + (if (eq? wait-time 1) ;; only one second left, steal the lock + (begin + (debug:print-info 0 *default-log-port* "stealing lock for " keyname) + (common:faux-unlock keyname force: #t))) + (common:faux-lock keyname wait-time: (- wait-time 1))) + #f) (begin - (rmt:set-var keyname (conc (current-process-id))) - (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) + (rmt:no-sync-set keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))))) (define (common:faux-unlock keyname #!key (force #f)) - (if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) (begin - (if (rmt:get-var keyname) (rmt:del-var keyname)) + (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) (define (common:in-running-test?) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -686,36 +686,33 @@ #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (if (common:faux-lock fname) - (let* ((dat (configf:config->alist cdat)) - (res - (begin - (with-output-to-file fname ;; first write out the file - (lambda () - (pp dat))) - - (if (common:file-exists? fname) ;; now verify it is readable - (if (configf:read-alist fname) - #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.") - (delete-file fname)) - #f)) - #f)))) - - (common:faux-unlock fname) - res) - (begin - (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) - #f))) - + (if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #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.") + (delete-file fname)) + #f)) + #f)))) + (common:faux-unlock fname) + res)) + ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map (lambda (section) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1842,24 +1842,40 @@ (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") db)) + +;; if we are not a server create a db handle. this is not finalized +;; so watch for problems. I'm still not clear if it is needed to manually +;; finalize sqlite3 dbs with the sqlite3 egg. +;; +(define (db:no-sync-db db-in) + (if db-in + db-in + (let ((db (db:open-no-sync-db))) + (set! *no-sync-db* db) + db))) (define (db:no-sync-set db var val) - (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + +(define (db:no-sync-del! db var) + (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) (define (db:no-sync-get/default db var default) (let ((res default)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db + (db:no-sync-db db) "SELECT val FROM no_sync_metadat WHERE var=?;" var) (if res - (let ((newres (string->number res))) + (let ((newres (if (string? res) + (string->number res) + #f))) (if newres newres res)) res))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -757,10 +757,12 @@ work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) (exit 4)))) ))) +;; DO NOT USE - caching of configs is handled in launch:setup now. +;; (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") @@ -870,21 +872,29 @@ ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource ;;(BB> "launch:setup-body -- cachefiles="cachefiles) (cond ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME - ((and (not force-reread) mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache) + ((and (not force-reread) + mtcachef rccachef + use-cache + (get-environment-variable "MT_RUN_AREA_HOME") + (common:file-exists? mtcachef) + (common:file-exists? rccachef)) ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") (set! *configdat* (configf:read-alist mtcachef)) ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*) (set! *runconfigdat* (configf:read-alist rccachef)) (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) (set! *configstatus* 'fulldata) (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) *toppath*) + ;; there are no existing cached configs, do full reads of the configs and cache them ;; we have all the info needed to fully process runconfigs and megatest.config - ((and (not force-reread) mtcachef) ;; BB- why are we doing this without asking if caching is desired? + ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? + mtcachef + rccachef) ;; BB- why are we doing this without asking if caching is desired? ;;(BB> "launch:setup-body -- cond branch 2") (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect mtconfig environ-patt: "env-override" given-toppath: toppath @@ -933,19 +943,19 @@ sections: sections))) (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) (rccachef (cdr cachefiles))) (if rccachef (configf:write-alist runconfigdat rccachef)) - (set! *runconfigdat* runconfigdat) (if mtcachef (configf:write-alist *configdat* mtcachef)) + (set! *runconfigdat* runconfigdat) (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table - (begin (set! *configdat* (make-hash-table)) - ;;(BB> "launch:setup-body -- 3 set! *configdat*="*configdat*) - ) + (set! *configdat* (make-hash-table)) ))) + ;; else read what you can and set the flag accordingly + ;; here we don't have either mtconfig or rccachef (else ;;(BB> "launch:setup-body -- cond branch 3 - else") (let* ((cfgdat (find-and-read-config (or (args:get-arg "-config") "megatest.config") environ-patt: "env-override" @@ -962,10 +972,12 @@ (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) + ;; COND ends here. + ;; additional house keeping (let* ((linktree (common:get-linktree))) (if linktree (begin (if (not (common:file-exists? linktree)) @@ -993,20 +1005,19 @@ (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") - ;;(exit 1) (set! *toppath* #f) ;; force it to be false so we return #f - #f - )) + #f)) + ;; one more attempt to cache the configs for future reading (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) (mtcachef (car cachefiles)) (rccachef (cdr cachefiles))) - (if (and rccachef *runconfigdat*) (configf:write-alist *runconfigdat* rccachef)) - (if (and mtcachef *configdat*) (configf:write-alist *configdat* mtcachef)) + (if (and rccachef *runconfigdat* (not (file-exists? rccachef))) (configf:write-alist *runconfigdat* rccachef)) + (if (and mtcachef *configdat* (not (file-exists? mtcachef))) (configf:write-alist *configdat* mtcachef)) (if (and rccachef mtcachef *runconfigdat* *configdat*) (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -562,11 +562,15 @@ ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") (let ((toppath (launch:setup))) (set! *didsomething* #t) ;; suppress the help output. - (runs:clean-cache (getenv "MT_TARGET")(args:get-arg "-runname") toppath))) + (runs:clean-cache (or (getenv "MT_TARGET") + (args:get-arg "-target") + (args:get-arg "-remtarg")) + (args:get-arg "-runname") + toppath))) (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) @@ -890,11 +894,12 @@ (begin (if (not (common:in-running-test?)) (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force-reread: #t) - (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig + ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. + )) ;; we can safely cache megatest.config since we have a valid runconfig data)))) (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup))) (push-directory *toppath*) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -843,10 +843,23 @@ (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) (define (rmt:tasks-get-last target runname) (rmt:send-receive 'tasks-get-last #f (list target runname))) + +;;====================================================================== +;; N O S Y N C D B +;;====================================================================== + +(define (rmt:no-sync-set var val) + (rmt:send-receive 'no-sync-set #f `(,var ,val))) + +(define (rmt:no-sync-get/default var default) + (rmt:send-receive 'no-sync-get/default #f `(,var ,default))) + +(define (rmt:no-sync-del! var) + (rmt:send-receive 'no-sync-del! #f `(,var))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2015,11 +2015,12 @@ (let (;; (db #f) (keys #f)) (if (launch:setup) (begin (full-runconfigs-read) ;; cache the run config - (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed + ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. + ) ;; do not cache here - need to be sure runconfigs is processed (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -475,10 +475,11 @@ (let ((legacy-sync (common:run-sync?)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) + (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls (debug:print-info 2 *default-log-port* "Periodic sync thread started.") (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (let* (;;(dbstruct (db:setup)) (mtdb (dbr:dbstruct-mtdb dbstruct)) ADDED tcmt.scm Index: tcmt.scm ================================================================== --- /dev/null +++ tcmt.scm @@ -0,0 +1,165 @@ +;; Copyright 2006-2017, 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 +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;; +;;====================================================================== +;; +;; Wrapper to enable running Megatest flows under teamcity +;; +;; 1. Run the megatest process and pass it all the needed parameters +;; 2. Every five seconds check for state/status changes and print the info +;; + +(use srfi-1 posix srfi-69 srfi-18) + +(declare (uses margs)) +(declare (uses rmt)) +(declare (uses common)) +(declare (uses megatest-version)) + +(include "megatest-fossil-hash.scm") +(include "db_records.scm") + +(define origargs (cdr (argv))) +(define remargs (args:get-args + (argv) + `( "-target" + "-reqtarg" + "-runname" + ) + `("-tc-repl" + ) + args:arg-hash + 0)) + +;; ##teamcity[testStarted name='suite.testName'] +;; ##teamcity[testStdOut name='suite.testName' out='text'] +;; ##teamcity[testStdErr name='suite.testName' out='error text'] +;; ##teamcity[testFailed name='suite.testName' message='failure message' details='message and stack trace'] +;; ##teamcity[testFinished name='suite.testName' duration='50'] +;; + +(define (print-changes-since data run-ids last-update tsname target runname) + (let ((now (current-seconds))) + (handle-exceptions + exn + (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + (for-each + (lambda (run-id) + (let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f last-update #f))) + ;; (print "DEBUG: got tests=" tests) + (for-each + (lambda (testdat) + (let* ((testn (db:test-get-fullname testdat)) + (testname (db:test-get-testname testdat)) + (itempath (db:test-get-item-path testdat)) + (tctname (if (string=? itempath "") testname (conc testname "." itempath))) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (duration (db:test-get-run_duration testdat)) + (comment (db:test-get-comment testdat)) + (logfile (db:test-get-final_logf testdat)) + (prevstat (hash-table-ref/default data testn #f)) + (newstat (if (equal? state "RUNNING") + "RUNNING" + (if (equal? state "COMPLETED") + status + "UNK")))) + ;; (print "DEBUG: testn=" testn " state=" state " status=" status " prevstat=" prevstat " newstat=" newstat) + (if (or (not prevstat) + (not (equal? prevstat newstat))) + (begin + (case (string->symbol newstat) + ((UNK) ) ;; do nothing + ((RUNNING) (print "##teamcity[testStarted name='" tctname "']")) + ((PASS SKIP) (print "##teamcity[testFinished name='" tctname "' duration='" duration "']")) + (else + (print "##teamcity[testFailed name='" tctname "' message='" comment "' details='" logfile "']"))) + (flush-output) + (hash-table-set! data testn newstat))))) + tests))) + run-ids)) + now)) + +(define (monitor pid) + (let ((run-ids #f) + (testdat (make-hash-table)) + (keys #f) + (last-update 0) + (target (or (args:get-arg "-target") + (args:get-arg "-reqtarg"))) + (runname (args:get-arg "-runname")) + (tsname #f)) + (if (and target runname) + (begin + (launch:setup) + (set! keys (rmt:get-keys)))) + (set! tsname (common:get-testsuite-name)) + (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup.") + (let loop () + (handle-exceptions + exn + ;; (print "Process done.") + (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + (let-values (((pidres exittype exitstatus) + (process-wait pid #t))) + (if (and keys + (or (not run-ids) + (null? run-ids))) + (let* ((runs (rmt:get-runs-by-patt keys + runname + target + #f ;; offset + #f ;; limit + #f ;; fields + 0 ;; last-update + )) + (header (db:get-header runs)) + (rows (db:get-rows runs)) + (run-ids-in (map (lambda (row) + (db:get-value-by-header row header "id")) + rows))) + (set! run-ids run-ids-in))) + ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) + (if keys + (set! last-update (print-changes-since testdat run-ids last-update tsname target runname))) + (if (eq? pidres 0) + (begin + (thread-sleep! 3) + (loop)) + (begin + ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) + (print "TCMT: All done.") + ))))))) + +;; (if (not (eq? pidres 0)) ;; (not exitstatus)) +;; (begin +;; (thread-sleep! 3) +;; (loop)) +;; (print "Process: megatest " (string-intersperse origargs " ") " is done."))))) +(define (main) + (let* ((mt-done #f) + (pid #f) + (th1 (make-thread (lambda () + (print "Running megatest " (string-intersperse origargs " ")) + (set! pid (process-run "megatest" origargs))) + "Megatest job")) + (th2 (make-thread (lambda () + (monitor pid)) + "Monitor job"))) + (thread-start! th1) + (thread-sleep! 1) ;; give the process time to get going + (thread-start! th2) + (thread-join! th2))) + +(if (args:get-arg "-tc-repl") + (repl) + (main)) + +;; (process-wait) +