79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
-
-
-
+
+
+
|
;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
(debug:print 4 "script: " script)
(rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f area-dat)
;; now launch the actual process
(call-with-environment-variables
(list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
(lambda ()
(let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
(pid (process-run cmd)))
(lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
(let* ((cmd (conc "exec " stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
(pid (process-run "/bin/bash" (list "-c" cmd))))
(rmt:test-set-top-process-pid run-id test-id pid area-dat)
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
|
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
-
+
+
+
+
-
+
|
runscript))))) ;; assume it is on the path
;; (rollup-status 0)
)
(change-directory top-path)
;; (set-signal-handler! signal/int (lambda ()
;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
;; WAS: Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
;; NOW: Do not run test test unless state is LAUNCHED
;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
;;
;; This is flawed. It should be a single transaction that tests for NOT_STARTED and updates to REMOTEHOSTSTART
(let ((test-info (rmt:get-testinfo-state-status run-id test-id area-dat)))
;;
(if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
(if (equal? (db:test-get-state test-info) "LAUNCHED") ;; '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(begin
(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))
|
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
|
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
|
+
+
+
-
+
+
+
+
+
+
|
(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))))))))
;; clean out step records from previous run if they exist
;; (rmt:delete-test-step-records run-id test-id)
;; Moving launch logs to MT_RUN_AREA_HOME/logs
;;
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
(let ((launchdir (configf:lookup *configdat* "setup" "launchdir"))) ;; (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
(if (not launchdir) ;; default
(change-directory (conc *toppath* "/logs")) ;; can assume this exists
(case (string->symbol launchdir)
((legacy)(change-directory work-area))
(else (change-directory launchdir)))))
(cond
((and launcher hosts) ;; must be using ssh hostname
(set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
(launcher
(set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
|
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
|
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
|
-
+
-
+
|
(launch-results (apply (if launchwait
cmd-run-with-stderr->list
process-run)
(if useshell
(let ((cmdstr (string-intersperse fullcmd " ")))
(if launchwait
cmdstr
(conc cmdstr " >> mt_launch.log 2>&1")))
(conc cmdstr " >> " work-area "/mt_launch.log 2>&1")))
(car fullcmd))
(if useshell
'()
(cdr fullcmd)))))
(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 (conc work-area "/mt_launch.log")
(lambda ()
(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"))
#:append))
(debug:print 2 "Launching completed, updating db")
(debug:print 2 "Launch results: " launch-results)
|