Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -358,10 +358,14 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== +;; Just some syntatic sugar +(define (rmt:register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path)) + (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) (define (rmt:get-test-info-by-id run-id test-id) (if (and (number? run-id)(number? test-id)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -286,11 +286,11 @@ ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. ;; ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") - ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED + ;; Now convert anything in allow-auto-rerun to NOT_STARTED ;; (for-each (lambda (state) (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) @@ -718,21 +718,21 @@ ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) - (rmt:general-call 'register-test run-id run-id test-name item-path) + (rmt:register-test run-id test-name item-path) (if (rmt:get-test-id run-id test-name item-path) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) (if (> numtries 0) (begin (thread-sleep! 0.5) (register-loop (- numtries 1))) (debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin - (rmt:general-call 'register-test run-id run-id test-name "") + (rmt:register-test run-id test-name "") (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) @@ -1002,11 +1002,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id run-id test-name "") + (rmt:register-test run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -1284,11 +1284,11 @@ ;; (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'register-test run-id run-id test-name item-path) + (rmt:register-test run-id test-name item-path) (set! test-id (rmt:get-test-id 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 (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -32,10 +32,13 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests +;; gets paths from configs and finds valid tests +;; returns hash of testname --> fullpath +;; (define (tests:get-all) (let* ((test-search-path (tests:get-tests-search-path *configdat*))) (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) @@ -583,10 +586,11 @@ ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) + (define (tests:get-testconfig test-name test-registry system-allowed) (let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -26,11 +26,11 @@ unit : basicserver.log runs.log ## basicserver.log : unittests/basicserver.scm ## script -c "./rununittest.sh basicserver $(DEBUG)" basicserver.log -%.log : unittests/%.scm ../*.scm +%.log : build unittests/%.scm script -c "./rununittest.sh $* $(DEBUG)" $*.log if logpro unit.logpro $*.html < $*.log > /dev/null;then echo ALLPASS;else echo ALLFAIL;mv $*.log $*.log.FAIL;fi server : cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -1,24 +1,23 @@ (define keys (rmt:get-keys)) -(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) +(test "get all legal tests" (list "test1" "test2") (sort (hash-table-keys (tests:get-all)) string<=?)) (test "register-run" #t (number? (rmt:register-run '(("SYSTEM" "key1")("RELEASE" "key2")) "myrun" "new" "n/a" "bob"))) -(test #f #t (rmt:tests-register-test 1 "nada" "")) -(test #f 1 (rmt:get-test-id 1 "nada" "")) -(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info 1 "nada" "") 3)) -(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info 1 "nada" "") 3)) +(test #f #t (rmt:register-test 1 "nada" "")) +(test #f 30001 (rmt:get-test-id 1 "nada" "")) +(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info-by-id 1 30001) 3)) ;; "nada" "") 3)) (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) -(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) +(test #f "key2" (vector-ref (car (vector-ref (mt:get-runs-by-patt '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) (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" @@ -48,16 +47,18 @@ ;; force keepgoing ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (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)) +(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") ;; SYSTEM/RELEASE +(hash-table-set! args:arg-hash "-runname" "testrun") +(test "Setup for a run" #t (begin (launch:setup-for-run) #t)) (define *tdb* #f) (define keyvals #f) (test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) + (print "keyvals=" kv ", keys=" keys) (set! keyvals kv)(list? keyvals))) (define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) (system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) @@ -67,38 +68,37 @@ (sqlite3#database? db))) (sqlite3#finalize! *tdb*) ;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) (define tconfig #f) -(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) +(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" (tests:get-all) 'return-procs ))) (set! tconfig tconf) (hash-table? tconf))) -(db:clean-all-caches) (test "set-megatest-env-vars" "ubuntu" (begin - (set-megatest-env-vars 1 inkeys: keys) + (runs: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") + (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keyvals environ-patt: "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))) +(test "get-run-info" #f (vector? (vector-ref (let ((rinf (rmt:get-run-info 1))) (set! rinfo rinf) rinf) 0))) -(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1))) +;; (test "get-key-vals" "key1" (car (db:get-key-vals *dbstruct* 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"))) + (let ((dat (rmt:testmeta-get-record "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*))) @@ -105,49 +105,54 @@ (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 "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) - "run1" ;; runname - (vector ;; test_records.scm tests:testqueue - "test1" ;; testname - tconfig ;; testconfig - '() ;; waitons - 0 ;; priority - #f ;; items - #f ;; itemsdat - "" ;; itempath - ) - args:arg-hash ;; flags (e.g. -itemspatt) - #f) - ;; (set! *verbosity* 0) - )))) - - - - - -(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 "launch-test" #t + (string? + (file-exists? + ;; (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (launch-test 30001 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) +;; "run1" ;; runname +;; (vector ;; test_records.scm tests:testqueue +;; "test1" ;; testname +;; tconfig ;; testconfig +;; (make-hash-table) ;; flags +;; #f ;; parent test +;; (tests:get-all) ;; test registry +;; 0 ;; priority +;; #f ;; items +;; #f ;; itemsdat +;; "" ;; itempath +;; ) +;; args:arg-hash ;; flags (e.g. -itemspatt) +;; #f) +;; ;; (set! *verbosity* 0) +;; )))) +;; +;; +;; +;; +;; +;; (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))) + ;; (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)))