| ︙ | | |
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
|
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
|
-
+
|
;; (diskfree (get-df (current-directory)))
;; (tmpfree (get-df "/tmp")))
(begin
;; (if (not (args:get-arg "-server"))
;; (server:client-setup db))
;; (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a")))
;; (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a")))
(set! kill-job? (test-get-kill-request db run-id test-name itemdat))
(set! kill-job? (test-get-kill-request db test-id)) ;; run-id test-name itemdat))
(test-set-meta-info db test-id run-id test-name itemdat minutes: minutes)
;; (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree)
(if kill-job?
(begin
(mutex-lock! m)
(let* ((pid (vector-ref exit-info 0)))
(if (number? pid)
|
| ︙ | | |
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
|
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
|
-
+
|
(thread-start! th2)
(thread-join! th2)
(mutex-lock! m)
;; (set! db (open-db))
;; (if (not (args:get-arg "-server"))
;; (server:client-setup db))
(let* ((item-path (item-list->path itemdat))
(testinfo (rdb:get-test-info db run-id test-name item-path)))
(testinfo (db:get-test-info-by-id db test-id))) ;; )) ;; run-id test-name item-path)))
(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)
(test-set-status! db test-id
(if kill-job? "KILLED" "COMPLETED")
;; Old logic:
;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran
|
| ︙ | | |
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
|
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
|
-
+
|
;;
;; <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-src-path disk-path testname itemdat)
(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))
(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))
|
| ︙ | | |
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
|
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
|
-
+
|
;; 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 db run-id testname item-path))
(let* ((testinfo (db:get-test-info-by-id db 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)
(db:test-set-rundir! db run-id testname "" lnkpath) ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print 2 "INFO: Creating " toptest-path " and link " lnkpath)
|
| ︙ | | |
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
|
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
|
-
-
+
+
-
+
|
(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))
(testinfo (rdb:get-test-info db run-id test-name item-path))
(test-id (db:test-get-id testinfo))
(test-id (db:get-test-id db run-id test-name item-path))
(testinfo (db:get-test-info-by-id db test-id))
(mt_target (string-intersperse (map cadr keyvallst) "/"))
(debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "-debug")) '())))
(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)))
;; set up the run work area for this test
(set! diskpath (get-best-disk *configdat*))
(if diskpath
(let ((dat (create-work-area db run-id test-path diskpath test-name itemdat)))
(let ((dat (create-work-area db run-id test-id test-path diskpath test-name itemdat)))
(set! work-area (car dat))
(set! toptest-work-area (cadr dat))
(debug:print 2 "INFO: Using work area " work-area))
(begin
(set! work-area (conc test-path "/tmp_run"))
(create-directory work-area #t)
(debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
|
| ︙ | | |