698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
|
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
|
-
+
|
;; megatest.config (cache if all vars avail)
;; returns:
;; *toppath*
;; side effects:
;; sets; *configdat* (megatest.config info)
;; *runconfigdat* (runconfigs.config info)
;; *configstatus* (status of the read data)
;;
;; *transport-type*
(define (launch:setup #!key (force #f))
(let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
(runname (common:args-get-runname))
(target (common:args-get-target))
(linktree (common:get-linktree))
(sections (if target (list "default" target) #f)) ;; for runconfigs
(mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
|
825
826
827
828
829
830
831
832
833
834
835
836
837
838
|
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
|
+
+
|
(debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
)))
(if (and *toppath*
(directory-exists? *toppath*))
(setenv "MT_RUN_AREA_HOME" *toppath*)
(begin
(debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")))
(server:set-transport)
;;(BB> "Transport is >"*transport-type*"<")
*toppath*))
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
(string->number (or m "10000")))))
|
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
|
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
|
-
+
|
(create-directory work-area #t)
(debug:print 0 *default-log-port* "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 'transport (conc (rmt:run-id->transport-type run-id)))
;; (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 )
|