| ︙ | | |
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
-
+
|
(top-path (assoc/default 'toppath cmdinfo))
(work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(ezsteps (assoc/default 'ezsteps cmdinfo))
;; (runremote (assoc/default 'runremote cmdinfo))
(transport (assoc/default 'transport cmdinfo))
(serverinf (assoc/default 'serverinf cmdinfo))
;; (serverinf (assoc/default 'serverinf cmdinfo))
(port (assoc/default 'port cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(env-ovrd (assoc/default 'env-ovrd cmdinfo))
(set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar
|
| ︙ | | |
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
+
-
+
+
+
+
+
+
+
|
;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
;;
(let ((test-info (rmt:get-testinfo-state-status run-id test-id)))
(if (not (member (db:test-get-state test-info) '("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")))
(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))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
(if (not (launch:setup-for-run force: #t))
(begin
(debug:print 0 "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
(change-directory *toppath*)
;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
;; seems non-ideal but could well break stuff
;; BUG? BUG? BUG?
(let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
(for-each (lambda (section)
(for-each (lambda (varval)
(let ((var (car varval))
|
| ︙ | | |
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
-
+
+
+
|
(list "MT_TEST_RUN_DIR" work-area)
(list "MT_TEST_NAME" test-name)
(list "MT_ITEM_INFO" (conc itemdat))
(list "MT_ITEMPATH" item-path)
(list "MT_RUNNAME" runname)
(list "MT_MEGATEST" megatest)
(list "MT_TARGET" target)
(list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree"))))
(list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-testsuite-name))))
(if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
;; environment overrides are done *before* the remaining critical envars.
|
| ︙ | | |
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
|
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
|
-
+
-
+
-
+
|
(bestsize 0))
(if disks
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (cond
((not (directory? dirpath))
(if (common:low-noise-print 20 "disks" disk-num)
(if (common:low-noise-print 50 "disks not a dir " disk-num)
(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it."))
-1)
((not (file-write-access? dirpath))
(if (common:low-noise-print 20 "disks" disk-num)
(if (common:low-noise-print 50 "disks not writeable " disk-num)
(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 20 "disks" disk-num)
(if (common:low-noise-print 50 "disks not a proper path " disk-num)
(debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it."))
-1)
(else
(get-df dirpath)))))
(if (> freespc bestsize)
(begin
(set! best dirpath)
|
| ︙ | | |
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
|
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
|
-
+
|
" - creating link from: " test-path "\n"
" to: " lnktarget)
;; If there is already a symlink delete it and recreate it.
(handle-exceptions
exn
(begin
(debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
(debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit))
(if (symbolic-link? lnktarget) (delete-file lnktarget))
(if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
(if (not (directory? test-path))
(create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes
|
| ︙ | | |
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
|
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
|
-
+
|
(debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
(set! cmdparms (base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda () ;; (list 'hosts hosts)
(write (list (list 'testpath test-path)
(list 'transport (conc *transport-type*))
(list 'serverinf *server-info*)
;; (list 'serverinf *server-info*)
(list 'toppath *toppath*)
(list 'work-area work-area)
(list 'test-name test-name)
(list 'runscript runscript)
(list 'run-id run-id )
(list 'test-id test-id )
;; (list 'item-path item-path )
|
| ︙ | | |