173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
)))))
(debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
;; now run logpro if needed
(if logpro-used
(let ((pid (process-run (conc "logpro " logpro-file " " (conc stepname ".html") " < " stepname ".log"))))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
(launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
(launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
(launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
|
>
|
|
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
)))))
(debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
;; now run logpro if needed
(if logpro-used
(let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
(pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
(launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
(launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
(launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
|
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
|
(lambda (section)
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if (and (string? var)(string? val))
(begin
(setenv var (config:eval-string-in-environment val))) ;; val)
(debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
(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))
|
|
|
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
|
(lambda (section)
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if (and (string? var)(string? val))
(begin
(safe-setenv var (config:eval-string-in-environment val))) ;; val)
(debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
(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))
|
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
|
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
(string->number (or m "10000")))))
(if disks
(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
(if res
(cdr res)
(begin
(if (common:low-noise-print 20 "No valid disks or no disk with enough space")
(debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
(exit 1))))))) ;; TODO - move the exit to the calling location and return #f
(define (launch:test-copy test-src-path test-path)
(let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
(string-substitute "TEST_TARG_PATH" test-path
(string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
|
|
|
>
>
>
>
>
>
>
>
>
>
>
|
|
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
|
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
(string->number (or m "10000")))))
(if disks
(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
(if res
(cdr res)
(begin
;; (if (common:low-noise-print 20 "No valid disks or no disk with enough space")
;; (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
;;(exit 1)
(if (null? disks)
(cons 1 (conc *toppath* "/runs"))
(let ((paths (sort disks (lambda (x y) (> (string-length (cadr x)) (string-length (cadr y)))))))
(let loop ((head (car paths)) (tail (cdr paths)))
(let ((result (handle-exceptions exn #f (create-directory (cadr head) #t))))
(if result
result
(if (null? tail)
(cons 1 (conc *toppath* "/runs"))
(loop (car tail) (cdr tail)))))))))))))) ;; the code creates the necessary directories if it does not exist and returns the path.
(define (launch:test-copy test-src-path test-path)
(let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
(string-substitute "TEST_TARG_PATH" test-path
(string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
|
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
|
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname 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)
(create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
;; create the directory for the tests dir links, this is needed no matter what...
(if (and (not (common:directory-exists? lnkbase))
(not (common:file-exists? lnkbase)))
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase)
(print-error-message exn (current-error-port)))
(create-directory lnkbase #t)))
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
;; thousands of unnecessary updates, cache the fact it was set and don't set it
;; again.
;; Now create the link from the test path to the link tree, however
|
|
>
|
|
|
|
|
|
|
>
|
>
>
>
|
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
|
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname 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)
(create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
;; create the directory for the tests dir links, this is needed no matter what... try up to three times
(let loop ((done 3))
(let ((success (if (and (not (common:directory-exists? lnkbase))
(not (common:file-exists? lnkbase)))
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase)
(print-error-message exn (current-error-port))
#t)
(create-directory lnkbase #t)
#f))))
(if (and (not success)(> done 0))
(loop (- done 1)))))
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
;; thousands of unnecessary updates, cache the fact it was set and don't set it
;; again.
;; Now create the link from the test path to the link tree, however
|