| ︙ | | |
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
-
+
-
+
|
;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
(open-run-close db:teststep-set-status! #f test-id stepname "start" "-" #f #f)
(cdb:remote-run db:teststep-set-status! #f test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(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)
(mutex-unlock! m)
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
(open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna))
(cdb:remote-run db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna))
(if logpro-used
(cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
|
| ︙ | | |
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
|
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
|
-
+
|
(th2 (make-thread runit)))
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(mutex-lock! m)
(let* ((item-path (item-list->path itemdat))
(testinfo (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path)))
(testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
;; Am I completed?
(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(begin
(debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
(tests:test-set-status! test-id
(if kill-job? "KILLED" "COMPLETED")
(cond
|
| ︙ | | |
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
-
+
-
+
|
;; <linkdir> - <target> - <testname> [ - <itempath> ]
;;
;; All log file links should be stored relative to the top of link path
;;
;; <target> - <testname> [ - <itempath> ]
;;
(define (create-work-area db run-id test-id test-src-path disk-path testname itemdat)
(let* ((run-info (db:get-run-info db run-id))
(let* ((run-info (cdb:remote-run db:get-run-info #f run-id))
(item-path (item-list->path itemdat))
(runname (db:get-value-by-header (db:get-row run-info)
(db:get-header run-info)
"runname"))
;; convert back to db: from rdb: - this is always run at server end
(key-vals (db:get-key-vals db run-id))
(key-vals (cdb:remote-run db:get-key-vals #f run-id))
(target (string-intersperse key-vals "/"))
(not-iterated (equal? "" item-path))
;; all tests are found at <rundir>/test-base or <linkdir>/test-base
(testtop-base (conc target "/" runname "/" testname))
(test-base (conc testtop-base (if not-iterated "" "/") item-path))
|
| ︙ | | |
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
|
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
|
-
+
+
-
+
|
;; 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.
;; NB - This is not working right - some top tests are not getting the path set!!!
(if (not (hash-table-ref/default *toptest-paths* testname #f))
(let* ((testinfo (db:get-test-info-by-id db test-id)) ;; run-id testname item-path))
(let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path))
(curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
(hash-table-set! *toptest-paths* testname curr-test-path)
;; NB// Was this for the test or for the parent in an iterated test?
(db:test-set-rundir! db run-id testname "" lnkpath) ;; toptest-path)
(cdb:test-set-rundir! *runremote* run-id testname item-path lnkpath) ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(create-directory toptest-path #t)
(hash-table-set! *toptest-paths* testname toptest-path)))))
|
| ︙ | | |
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
|
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
|
-
-
+
+
|
(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)
(item-path (item-list->path itemdat))
(test-id (open-run-close db:get-test-id db run-id test-name item-path))
(testinfo (open-run-close db:get-test-info-by-id db test-id))
(test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(testinfo (cdb:remote-run db:get-test-info-by-id #f test-id))
(mt_target (string-intersperse (map cadr keyvallst) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
(if (args:get-arg "-logging")(list "-logging") '()))))
(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))
|
| ︙ | | |
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
|
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
|
-
-
+
+
|
(list 'ezsteps ezsteps)
(list 'target mt_target)
(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))))))) ;; (string-intersperse keyvallst " "))))
;; clean out step records from previous run if they exist
(debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
(open-run-close db:delete-test-step-records db test-id)
;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
;; (open-run-close db:delete-test-step-records db test-id)
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
(tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(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
|
| ︙ | | |