︙ | | |
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
-
+
-
+
|
(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)
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(create-directory toptest-path #t)
(hash-table-set! *toptest-paths* testname toptest-path)))))
;; Now create the link from the test path to the link tree, however
;; if the test is iterated it is necessary to create the parent path
;; to the iteration. use pathname-directory to trim the path by one
;; level
(if (not not-iterated) ;; i.e. iterated
(let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path))))
(debug:print 2 "INFO: Creating iterated parent " iterated-parent)
(debug:print-info 2 "Creating iterated parent " iterated-parent)
(create-directory iterated-parent #t)))
(if (symbolic-link? lnkpath) (delete-file lnkpath))
(if (not (or (file-exists? lnkpath)
(symbolic-link? lnkpath)))
(create-symbolic-link toptest-path lnkpath))
|
︙ | | |
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
|
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
|
-
+
|
;; (if (and (file-exists? testlink)
;; (or (regular-file? testlink)
;; (symbolic-link? testlink)))
;; (system (conc "rm -f " testlink)))
;; (system (conc "ln -sf " test-path " " testlink)))
(if (directory? test-path)
(begin
(let* ((cmd (conc "rsync -av" (if (> *verbosity* 1) "" "q") " " test-src-path "/ " test-path "/"))
(let* ((cmd (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"))
(status (system cmd)))
(if (not (eq? status 0))
(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
(list lnkpathf lnkpath ))
(list #f #f))))
;; 1. look though disks list for disk with most space
|
︙ | | |
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
|
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
|
-
+
|
(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 (open-run-close 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))
(debug:print-info 2 "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")))
(set! cmdparms (base64:base64-encode (with-output-to-string
(lambda () ;; (list 'hosts hosts)
(write (list (list 'testpath test-path)
|
︙ | | |
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
|
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
|
-
+
|
(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 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
(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))))
|
︙ | | |