Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -231,21 +231,23 @@
(archive-path (if (vector? archive-block-info)
(vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
#f)) ;; no archive found?
(archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
- ;; some sanity checks, move an existing path out of the way
+ ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
;;
- (if (and prev-test-physical-path
+ (if (and (not toplevel/children) ;; special handling needed for toplevel with children
+ prev-test-physical-path
(file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
(let* ((base (pathname-directory prev-test-physical-path))
(dirn (pathname-file prev-test-physical-path))
(newn (conc base "/." dirn)))
(debug:print 0 "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
- (file-move prev-test-physical-path newn)))
+ (rename-file prev-test-physical-path newn)))
- (if archive-path ;; no point in proceeding if there is no actual archive
+ (if (and archive-path ;; no point in proceeding if there is no actual archive
+ (not toplevel/children))
(begin
;; CREATE WORK AREA
;; test-src-path == #f ==> don't copy in data from tests directory
;; itemdat == string ==> use directly
(create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -391,13 +391,33 @@
(hash-table-ref/default
(or configf (read-config "megatest.config" #f #t))
"disks" '("none" "")))
;;======================================================================
-;; T A R G E T S
+;; T A R G E T S , S T A T E , S T A T U S ,
+;; R U N N A M E A N D T E S T P A T T
;;======================================================================
+(define (common:args-get-state)
+ (or (args:get-arg "-state")(args:get-arg ":state")))
+
+(define (common:args-get-status)
+ (or (args:get-arg "-status")(args:get-arg ":status")))
+
+(define (common:args-get-testpatt)
+ (let* ((args-testpatt (or (args:get-arg "-testpatt")
+ (args:get-arg "-runtests")
+ "%"))
+ (testpatt (or (and (equal? args-testpatt "%")
+ (getenv "TESTPATT"))
+ args-testpatt)))
+ testpatt))
+
+(define (common:args-get-runname)
+ (or (args:get-arg "-runname")
+ (args:get-arg ":runname")))
+
(define (common:args-get-target #!key (split #f))
(let* ((keys (keys:config-get-fields *configdat*))
(numkeys (length keys))
(target (if (args:get-arg "-reqtarg")
(args:get-arg "-reqtarg")
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -555,11 +555,12 @@
(define (launch:cache-config)
;; if we have a linktree and -runtests and -target and the directory exists dump the config
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
(if (and *configdat*
- (args:get-arg "-runtests"))
+ (or (args:get-arg "-run")
+ (args:get-arg "-runtests")))
(let* ((linktree (get-environment-variable "MT_LINKTREE"))
(target (common:args-get-target))
(runname (or (args:get-arg "-runname")
(args:get-arg ":runname")))
(fulldir (conc linktree "/"
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -434,10 +434,12 @@
(if (args:get-arg "-itempatt")
(let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
(debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
+
+
(on-exit std-exit-procedure)
;;======================================================================
;; Misc general calls
@@ -853,14 +855,14 @@
(debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found")
(exit 1))
;; put test parameters into convenient variables
(runs:operate-on action
target
- (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (args:get-arg "-testpatt")
- state: (or (args:get-arg "-state")(args:get-arg ":state") )
- status: (or (args:get-arg "-status")(args:get-arg ":status"))
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ (common:args-get-testpatt) ;; (args:get-arg "-testpatt")
+ state: (common:args-get-state)
+ status: (common:args-get-status)
new-state-status: (args:get-arg "-set-state-status")))
(set! *didsomething* #t)))))
(if (args:get-arg "-remove-runs")
(general-run-call
@@ -931,13 +933,14 @@
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
(if (launch:setup-for-run)
(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(runpatt (args:get-arg "-list-runs"))
- (testpatt (if (args:get-arg "-testpatt")
- (args:get-arg "-testpatt")
- "%"))
+ (testpatt (common:args-get-testpatt))
+ ;; (if (args:get-arg "-testpatt")
+ ;; (args:get-arg "-testpatt")
+ ;; "%"))
(keys (db:get-keys dbstruct))
;; (runsda t (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
#f #f '("id" "runname" "state" "status" "owner" "event_time" "comment")))
(runstmp (db:get-rows runsdat))
@@ -1145,12 +1148,13 @@
"-runall"
"run all tests"
(lambda (target runname keys keyvals)
(runs:run-tests target
runname
- (or (args:get-arg "-testpatt")
- "%")
+ (common:args-get-testpatt)
+ ;; (or (args:get-arg "-testpatt")
+ ;; "%")
user
args:arg-hash))))
;;======================================================================
;; run one test
@@ -1167,11 +1171,11 @@
;; - step completed, exit status, timestamp
;; 6. test phone home
;; - if test run time > allowed run time then kill job
;; - if cannot access db > allowed disconnect time then kill job
-(if (args:get-arg "-runtests")
+(if (or (args:get-arg "-run")(args:get-arg "-runtests"))
(general-run-call
"-runtests"
"run a test"
(lambda (target runname keys keyvals)
;;
@@ -1185,11 +1189,11 @@
;; runname
;; (args:get-arg "-runtests")
;; #f))))
(runs:run-tests target
runname
- (args:get-arg "-runtests")
+ (common:args-get-testpatt) ;; (args:get-arg "-runtests")
user
args:arg-hash))))
;;======================================================================
;; Rollup into a run
@@ -1604,11 +1608,12 @@
;;======================================================================
;; Wait on a run to complete
;;======================================================================
(if (and (args:get-arg "-run-wait")
- (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now
+ (not (or (args:get-arg "-run")
+ (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
(begin
(if (not (launch:setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
@@ -1675,14 +1680,14 @@
(set! *time-to-exit* #t)
(thread-join! *watchdog*)
(if (not (eq? *globalexitstatus* 0))
- (if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
+ (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
(debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
(exit 0))
(case *globalexitstatus*
((0)(exit 0))
((1)(exit 1))
((2)(exit 2))
(else (exit 3)))))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -47,14 +47,17 @@
(begin
(debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
(exit 1)))))
(runrec (runs:runrec-make-record))
(target (common:args-get-target))
- (runname (or (args:get-arg "-runname")
- (args:get-arg ":runname")))
- (testpatt (or (args:get-arg "-testpatt")
- (args:get-arg "-runtests")))
+ (runname (common:args-get-runname))
+ (testpatt (common:args-get-testpatt))
+;; (args-testpatt (or (args:get-arg "-testpatt")
+;; (args:get-arg "-runtests")))
+;; (testpatt (or (and (equal? args-testpatt "%")
+;; (getenv "TESTPATT"))
+;; args-testpatt))
(keys (keys:config-get-fields mconfig))
(keyvals (keys:target->keyval keys target))
(toppath *toppath*)
(envdat keyvals) ;; initial values start with keyvals
(runconfig #f)
@@ -84,10 +87,14 @@
(begin
(debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
(if db (sqlite3:finalize! db))
(exit 1)))
;; Now have runconfigs data loaded, set environment vars
+
+ ;; Only now can we calculate the testpatt
+ (set! testpatt (common:args-get-testpatt))
+
(for-each (lambda (section)
(for-each (lambda (varval)
(set! envdat (append envdat (list varval)))
(safe-setenv (car varval)(cadr varval)))
(configf:get-section runconfig section)))