Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1582,11 +1582,11 @@ (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) ((flush sync) (server:reply return-address qry-sig #t 1)) ;; (length data))) ((set-verbosity) (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) + (server:reply return-address qry-sig #t (list #t *verbosity*))) ((killserver) (let ((hostname (car *runremote*)) (port (cadr *runremote*)) (pid (car params))) (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -130,22 +130,25 @@ (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) -(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)) - (let ((keys (if inkeys inkeys (cdb:remote-run db:get-keys #f))) - (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) +(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) + (let* ((target (or (args:get-arg "-reqtarg") + (args:get-arg "-target"))) + (keys (if inkeys inkeys (cdb:remote-run db:get-keys #f))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) ;; get the info from the db and put it in the cache (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) - (hash-table-set! vals key (cdb:remote-run db:get-run-key-val #f run-id key))) - keys))) + (hash-table-set! vals (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key)))) + keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -92,11 +92,10 @@ (define server-pid #f) (test "launch server" #t (let ((pid (process-fork (lambda () ;; (daemon:ize) (server:launch 'http))))) (set! server-pid pid) - (print "pid=" server-pid) (number? pid))) (thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. (test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2))) ;; host ip pullport pubport @@ -105,16 +104,10 @@ (test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*))) (test #f #t (let ((res (client:login *runremote*))) (car res))) -(test "server stop" #f (let ((hostname (car *runremote*)) - (port (cadr *runremote*))) - (tasks:kill-server #t hostname port server-pid 'http) - (open-run-close tasks:get-best-server tasks:open-db))) - -(exit 1) ;;====================================================================== ;; C O N F I G F I L E S ;;====================================================================== @@ -175,26 +168,26 @@ ;; (cdb:set-verbosity *runremote* *verbosity*) (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) -(test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) +(test "get-keys" "SYSTEM" (car (db:get-keys *db*))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada") (list ":runname" ":state" ":status") (list "-h") args:arg-hash 0)) -(test "register-run" #t (number? (runs:register-run *db* - (db:get-keys *db*) - '(("SYSTEM" "key1")("RELEASE" "key2")) - "myrun" - "new" - "n/a" - "bob"))) +(test "register-run" #t (number? (db:register-run *db* + (db:get-keys *db*) + '(("SYSTEM" "key1")("RELEASE" "key2")) + "myrun" + "new" + "n/a" + "bob"))) (test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) (test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) (test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) (test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) @@ -205,11 +198,11 @@ ;; D B ;;====================================================================== (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) (test #f (vector '("SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time") '()) - (runs:get-runs-by-patt db keys "%")) + (runs:get-runs-by-patt db keys "%" "key1/key2")) (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) (test #f #t (runs:operate-on 'print "%" "%" "%")) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" (setenv "BLAHFOO" "1234") @@ -258,20 +251,24 @@ (define tconfig #f) (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* 20) + +(set! *verbosity* (list 0 1 2)) + (test "Run a test" #t (general-run-call "-runtests" "run a test" - (lambda (target runname keys keynames keyvallst) + (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) (run:test 1 ;; run-id + #f ;; run-info is yet only a dream + keyvallst ;; (keys:target->keyval keys target) (args:get-arg ":runname") - (keys:target->keyval keys target) (vector "test1" ;; testname tconfig ;; testconfig '() ;; waitons 0 ;; priority @@ -280,15 +277,25 @@ #f ;; spare ) args:arg-hash ;; flags (e.g. -itemspatt) #f))))) -(test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) - (non-cached (db:get-test-info-not-cached-by-id db 2))) - (print "\nCached: " cached-info) - (print "Noncached: " non-cached) - (equal? cached-info non-cached))) + + + + +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) + +(exit 1) +;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) +;; (non-cached (db:get-test-info-not-cached-by-id db 2))) +;; (print "\nCached: " cached-info) +;; (print "Noncached: " non-cached) +;; (equal? cached-info non-cached))) (change-directory test-work-dir) (test "Add a step" #t (begin (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") @@ -396,11 +403,16 @@ (hash-table-set! args:arg-hash ":runname" "%") (test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) (print "Waiting for server to be done, should be about 20 seconds") -(cdb:kill-server *runremote*) +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) + +;; (cdb:kill-server *runremote*) ;; (thread-join! th1 th2 th3) ;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) ;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())