26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
-
+
|
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))
(use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
|
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
-
+
|
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (common:file-exists? tconfig-file)
(file-read-access? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(let ((newtcfg (configf:read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
|