Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -412,11 +412,11 @@
(let* ((item-path (item-list->path itemdat))
(runname (db:get-value-by-header (db:get-row run-info)
(db:get-header run-info)
"runname"))
;; convert back to db: from rdb: - this is always run at server end
- (target (string-intersperse key-vals "/"))
+ (target (string-intersperse (map cadr key-vals) "/"))
(not-iterated (equal? "" item-path))
;; all tests are found at <rundir>/test-base or <linkdir>/test-base
(testtop-base (conc target "/" runname "/" testname))
@@ -595,11 +595,11 @@
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
(item-path (item-list->path itemdat))
;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(testinfo (cdb:get-test-info-by-id *runremote* test-id))
- (mt_target (string-intersperse key-vals "/"))
+ (mt_target (string-intersperse (map cadr key-vals) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
(if (args:get-arg "-logging")(list "-logging") '()))))
(if hosts (set! hosts (string-split hosts)))
;; set the megatest to be called on the remote host
(if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -230,11 +230,12 @@
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table))
- (test-names '()))
+ (test-names '())
+ (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names
(set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
@@ -263,28 +264,35 @@
;; (sqlite3:finalize! db)
;; now add non-directly referenced dependencies (i.e. waiton)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
- (debug:print-info 4 "hed=" hed " at top of loop")
(let* ((config (tests:get-testconfig hed 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print 0 "ERROR: non-existent required test \"" hed "\"")
(if db (sqlite3:finalize! db))
(exit 1)))))
(debug:print-info 8 "waitons string is " instr)
- (string-split (cond
- ((procedure? instr)
- (let ((res (instr)))
- (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
- res))
- ((string? instr) instr)
- (else
- ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
- ""))))))
+ (let ((newwaitons
+ (string-split (cond
+ ((procedure? instr)
+ (let ((res (instr)))
+ (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
+ res))
+ ((string? instr) instr)
+ (else
+ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
+ "")))))
+ (filter (lambda (x)
+ (if (member x all-test-names)
+ #t
+ (begin
+ (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x)
+ #f)))
+ newwaitons)))))
(debug:print-info 8 "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member hed waitons)
(begin
@@ -451,10 +459,12 @@
(debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(cdb:tests-register-test *runremote* run-id test-name item-path)
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))))
(debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (cdb:get-test-info-by-id *runremote* test-id))))
+ (if (not testdat) ;; should NOT happen
+ (debug:print 0 "ERROR: failed to get test record for test-id " test-id))
(set! test-id (db:test-get-id testdat))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
@@ -684,12 +694,12 @@
(args:get-arg "-target"))))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
- (if (args:get-arg "-server")
- (open-run-close server:start db (args:get-arg "-server")))
+ ;; (if (args:get-arg "-server")
+ ;; (open-run-close server:start db (args:get-arg "-server")))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
(runconfig (read-config runconfigf #f #t environ-patt: #f)))
Index: tests/tests.scm
==================================================================
--- tests/tests.scm
+++ tests/tests.scm
@@ -235,10 +235,13 @@
(hash-table-set! args:arg-hash "-testpatt" "%")
(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2")
(test "Setup for a run" #t (begin (setup-for-run) #t))
(define *tdb* #f)
+(define keyvals #f)
+(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target"))))
+ (set! keyvals kv)(list? keyvals)))
(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing"))
(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath))
(print "Using " testdbpath " for test db")
@@ -252,37 +255,71 @@
(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs)))
(set! tconfig tconf)
(hash-table? tconf)))
(db:clean-all-caches)
-(set! *verbosity* (list 0 1 2))
+(test "set-megatest-env-vars"
+ "ubuntu"
+ (begin
+ (set-megatest-env-vars 1 inkeys: keys)
+ (get-environment-variable "SYSTEM")))
+(test "setup-env-defaults"
+ "see this variable"
+ (begin
+ (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
+ (get-environment-variable "ALLTESTS")))
+
+(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash)))
+
+(define rinfo #f)
+(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1)))
+ (set! rinfo rinf)
+ rinf) 0)))
+(test "get-key-vals" "SYSTEM" (car (cdb:remote-run db:get-key-vals #f 1)))
+(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table)))
+
+(test "update-test_meta" "test1" (begin
+ (runs:update-test_meta "test1" tconfig)
+ (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1")))
+ (vector-ref dat 1))))
+
+(define test-path "tests/test1")
+(define disk-path #f)
+(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*)))
+ (set! disk-path d)
+ d))))
+(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
+(test #f "" (item-list->path '()))
-(test #f #t (set-megatest-env-vars 1 inkeys: keys))
-(test #f #t (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars"))
+(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))
+
(test "Run a test" #t (general-run-call
"-runtests"
"run a test"
(lambda (target runname keys keyvallst)
(let ((test-patts "test%"))
;; (runs:run-tests target runname test-patts user (make-hash-table))
;; (run:test run-id run-info key-vals runname test-record flags parent-test)
+ ;; (set! *verbosity* 22) ;; (list 0 1 2))
(run:test 1 ;; run-id
#f ;; run-info is yet only a dream
keyvallst ;; (keys:target->keyval keys target)
- (args:get-arg ":runname")
- (vector
+ "run1" ;; runname
+ (vector ;; test_records.scm tests:testqueue
"test1" ;; testname
tconfig ;; testconfig
'() ;; waitons
0 ;; priority
#f ;; items
#f ;; itemsdat
- #f ;; spare
+ "" ;; itempath
)
args:arg-hash ;; flags (e.g. -itemspatt)
- #f)))))
+ #f)
+ ;; (set! *verbosity* 0)
+ ))))