Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -47,11 +47,12 @@ get-steps-data login testmeta-get-record)) ;; These are called by the server on recipt of /api calls - +;; - keep it simple, only return the actual result of the call, i.e. no meta info here +;; (define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2466,45 +2466,47 @@ (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) - (if dbdat - (let* ((dbpath (db:dbdat-get-path dbdat)) - (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline - (dbfj (conc dbpath "-journal"))) - (if (handle-exceptions - exn - (begin - (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) - (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) - (file-exists? dbfj)) - (case count - ((6) - (thread-sleep! 0.2) - (db:delay-if-busy count: 5)) - ((5) - (thread-sleep! 0.4) - (db:delay-if-busy count: 4)) - ((4) - (thread-sleep! 0.8) - (db:delay-if-busy count: 3)) - ((3) - (thread-sleep! 1.6) - (db:delay-if-busy count: 2)) - ((2) - (thread-sleep! 3.2) - (db:delay-if-busy count: 1)) - ((1) - (thread-sleep! 6.4) - (db:delay-if-busy count: 0)) - (else - (debug:print-info 0 "delaying db access due to high database load.") - (thread-sleep! 12.8)))) - db) - "bogus result from db:delay-if-busy")) + (if (not (configf:lookup *configdat* "server" "delay-on-busy")) + (and dbdat (db:dbdat-get-db dbdat)) + (if dbdat + (let* ((dbpath (db:dbdat-get-path dbdat)) + (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline + (dbfj (conc dbpath "-journal"))) + (if (handle-exceptions + exn + (begin + (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) + (thread-sleep! 1) + (db:delay-if-busy count (- count 1))) + (file-exists? dbfj)) + (case count + ((6) + (thread-sleep! 0.2) + (db:delay-if-busy count: 5)) + ((5) + (thread-sleep! 0.4) + (db:delay-if-busy count: 4)) + ((4) + (thread-sleep! 0.8) + (db:delay-if-busy count: 3)) + ((3) + (thread-sleep! 1.6) + (db:delay-if-busy count: 2)) + ((2) + (thread-sleep! 3.2) + (db:delay-if-busy count: 1)) + ((1) + (thread-sleep! 6.4) + (db:delay-if-busy count: 0)) + (else + (debug:print-info 0 "delaying db access due to high database load.") + (thread-sleep! 12.8)))) + db) + "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -242,11 +242,12 @@ (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) - (res #f)) + (res #f) + (success #t)) (handle-exceptions exn (if (> numretries 0) (begin (mutex-unlock! *http-mutex*) @@ -273,24 +274,27 @@ ;; process and return it. (let* ((send-recieve (lambda () (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) - (set! res (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (hash-table-delete! *runremote* run-id) - ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine. - #f) - (with-input-from-request ;; was dat - fullurl - (list (cons 'key "thekey") - (cons 'cmd cmd) - (cons 'params params)) - read-string))) + (set! res (vector + success + (handle-exceptions + exn + (begin + (set! success #f) + (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (hash-table-delete! *runremote* run-id) + ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine. + #f) + (with-input-from-request ;; was dat + fullurl + (list (cons 'key "thekey") + (cons 'cmd cmd) + (cons 'params params)) + read-string)))) ;; Shouldn't this be a call to the managed call-all-connections stuff above? (close-all-connections!) (mutex-unlock! *http-mutex*) )) (time-out (lambda () Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -52,10 +52,20 @@ (> queries-per-second 10)) (begin (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) + +(define (rmt:get-connection-info run-id) + (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) + (if cinfo + cinfo + ;; NB// can cache the answer for server running for 10 seconds ... + ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) + (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) + (client:setup run-id) + #f)))) ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 0)) @@ -71,32 +81,29 @@ (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) (mutex-unlock! *db-multi-sync-mutex*) (let* ((run-id (if rid rid 0)) - (connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) - (if cinfo - cinfo - ;; NB// can cache the answer for server running for 10 seconds ... - ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) - (if (tasks:server-running-or-starting? (db:delay-if-busy - (tasks:open-db)) - run-id) - (let ((res (client:setup run-id))) - (if res - (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully) - #f)) - #f)))) + (connection-info (rmt:get-connection-info run-id)) (jparams (db:obj->string params))) (if connection-info - (let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + ;; use the server if have connection info + (let* ((dat (http-transport:client-api-send-receive run-id connection-info cmd jparams)) + (res (if dat (vector-ref dat 1) #f)) + (success (if dat (vector-ref dat 0) #f))) (http-transport:server-dat-update-last-access connection-info) - (if res - (or(db:string->obj res) - (begin - (thread-sleep! 0.5) - (rmt:send-receive cmd rid params attempnum: (+ attemptnum 1)))) + (if success + (db:string->obj res) + ;; (if (< attemptnum 100) + ;; (begin + ;; (hash-table-delete! *runremote* run-id) + ;; (thread-sleep! 0.5) + ;; (rmt:send-receive cmd rid params attempnum: (+ attemptnum 1))) + ;; (begin + ;; (print-call-chain) + ;; (debug:print 0 "ERROR: too many attempts to communicate have failed. Giving up. Kill your mtest processes and start over") + ;; (exit 1))))) (begin ;; let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; no longer killing the server in http-transport:client-api-send-receive @@ -122,11 +129,11 @@ (begin (debug:print-info 0 "Max average query, " (inexact->exact (round curr-max-val)) "ms (" (car curr-max) ") exceeds " max-avg-qry "ms, try starting server ...") (server:kind-run run-id)) (debug:print-info 3 "Max average query, " (inexact->exact (round curr-max-val)) "ms (" (car curr-max) ") below " max-avg-qry "ms, not starting server..."))) (rmt:open-qry-close-locally cmd run-id params))))))) - + (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin @@ -205,15 +212,17 @@ (mutex-unlock! *db-multi-sync-mutex*))) res))) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) - (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) - (res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) - (if res - (db:string->obj res) - res))) + (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) + (dat (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + (if (and dat (vector-ref dat 0)) + (db:string->obj (vector-ref dat 1)) + (begin + (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " res) + res)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string (lambda () Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -19,11 +19,14 @@ # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : test1 test2 test3 test4 test5 test6 test7 test8 test9 +all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9 + +unit : + ./rununittest.sh basicserver $(DEBUG) server : cd ..;make -j;make install cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -4,14 +4,20 @@ # # Ensure all is made (cd ..;make && make install) +# put megatest on path from correct location +mtbindir=$(readlink -f ../bin) + +export PATH="${mtbindir}:$PATH" + # Clean setup # -rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db -rm -rf simplelinks/ simpleruns/ simplerun/db/ +dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db +rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db +rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -10,11 +10,11 @@ # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable -linktree #{shell readlink -f #{getenv PWD}/../simplelinks} +linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed @@ -27,6 +27,6 @@ [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] -disk0 #{shell readlink -f #{getenv PWD}/../simpleruns} +disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -24,17 +24,17 @@ (lambda (file) (print "Loading " file) (load file)) files)) -(define *runremote* #f) - (let* ((unit-test-name (list-ref (argv) 4)) (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) + + (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -2,113 +2,175 @@ ;; S E R V E R ;;====================================================================== ;; Run like this: ;; -;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) - -(set! *transport-type* 'http) - -(test "setup for run" #t (begin (setup-for-run) - (string? (getenv "MT_RUN_AREA_HOME")))) - -(test "server-register, get-best-server" #t (let ((res #f)) - (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) - (set! res (open-run-close tasks:get-best-server tasks:open-db)) - (number? (vector-ref res 3)))) - -(test "de-register server" #f (let ((res #f)) - (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) - (vector? (open-run-close tasks:get-best-server tasks:open-db)))) - -(define server-pid #f) - -;; Not sure how the following should work, replacing it with system of megatest -server -;; (test "launch server" #t (let ((pid (process-fork (lambda () -;; ;; (daemon:ize) -;; (server:launch 'http))))) -;; (set! server-pid pid) -;; (number? pid))) -(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") - -(let loop ((n 10)) - (thread-sleep! 1) ;; need to wait for server to start. - (let ((res (open-run-close tasks:get-best-server tasks:open-db))) - (print "tasks:get-best-server returned " res) - (if (and (not res) - (> n 0)) - (loop (- n 1))))) - -(test "get-best-server" #t (begin - (client:launch) - (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) - (vector? dat)))) - -(define *keys* (keys:config-get-fields *configdat*)) -(define *keyvals* (keys:target->keyval *keys* "a/b/c")) - -(test #f #t (string? (car *runremote*))) -(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) - -(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test - -;; RUNS -(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) -(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) - (vector-ref (vector-ref rinfo 1) 3))) -(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) - -;; TESTS -(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) -(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) -(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) -(test "sync back" #t (> (rmt:sync-inmem->db) 0)) -(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) -(test "get keys" #t (list? (rmt:get-keys))) -(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) -(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) - (db:test-get-comment trec))) - -;; MORE RUNS -(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) - (header (vector-ref runs 0)) - (data (vector-ref runs 1))) - (and (list? header) - (list? data) - (vector? (car data))))) - -(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) -(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) - -;;====================================================================== -;; D B -;;====================================================================== - -(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) -(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) - (+ (db:test-get-pass_count dat) - (db:test-get-fail_count dat)))) - -(define testregistry (make-hash-table)) -(for-each - (lambda (tname) - (for-each - (lambda (itempath) - (let ((tkey (conc tname "/" itempath)) - (rpass (random 10)) - (rfail (random 10))) - (hash-table-set! testregistry tkey (list tname itempath)) - (rmt:general-call 'register-test 1 tname itempath) - (let* ((tid (rmt:get-test-id 1 tname itempath)) - (tdat (rmt:get-test-info-by-id tid))) - (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) - (let* ((resdat (rmt:get-test-info-by-id tid))) - (test "set/get pass fail counts" (list rpass rfail) - (list (db:test-get-pass_count resdat) - (db:test-get-fail_count resdat))))))) - (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) - (list "test1" "test2" "test3" "test4" "test5")) - - -(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) - +;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(delete-file* "logs/1.log") +(define run-id 1) + +(test "setup for run" #t (begin (launch:setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +;; NON Server tests go here + +(test #f #f (db:dbdat-get-path *db*)) +(test #f #f (db:get-run-name-from-id *db* run-id)) + +;; (exit) + +;; Server tests go here +(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) +(server:kind-run run-id) +(test "did server start within 20 seconds?" + #t + (let loop ((remtries 20) + (running (tasks:server-running-or-starting? (db:delay-if-busy + (tasks:open-db)) + run-id))) + (if running + (> running 0) + (if (> remtries 0) + (begin + (thread-sleep! 1.1) + (loop (- remtries 1) + (tasks:server-running-or-starting? (db:delay-if-busy + (tasks:open-db)) + run-id))))))) + +(test "did server become available" #t + (let loop ((remtries 10) + (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) + (if res + (vector? res) + (begin + (if (> remtries 0) + (begin + (thread-sleep! 1.1) + (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) + res))))) + +(test #f #f (not (client:setup run-id))) +(test #f #f (not (hash-table-ref/default *runremote* run-id #f))) +(test #f '(#t "successful login") (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id)) +(test #f '(#t "successful login") (rmt:login run-id)) +(test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) +(test #f '() (rmt:get-all-run-ids)) +(test #f #f (rmt:get-run-name-from-id run-id)) + +;; test killing server +;; +(tasks:kill-server-run-id run-id) + +(test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) + +;; (test #f #f (client:setup run-id)) + +;; (set! *transport-type* 'http) +;; +;; (test "setup for run" #t (begin (launch:setup-for-run) +;; (string? (getenv "MT_RUN_AREA_HOME")))) +;; +;; (test "server-register, get-best-server" #t (let ((res #f)) +;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) +;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) +;; (number? (vector-ref res 3)))) +;; +;; (test "de-register server" #f (let ((res #f)) +;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) +;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) +;; +;; (define server-pid #f) +;; +;; ;; Not sure how the following should work, replacing it with system of megatest -server +;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; ;; (daemon:ize) +;; ;; (server:launch 'http))))) +;; ;; (set! server-pid pid) +;; ;; (number? pid))) +;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; +;; (let loop ((n 10)) +;; (thread-sleep! 1) ;; need to wait for server to start. +;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) +;; (print "tasks:get-best-server returned " res) +;; (if (and (not res) +;; (> n 0)) +;; (loop (- n 1))))) +;; +;; (test "get-best-server" #t (begin +;; (client:launch) +;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) +;; (vector? dat)))) +;; +;; (define *keys* (keys:config-get-fields *configdat*)) +;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) +;; +;; (test #f #t (string? (car *runremote*))) +;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) +;; +;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test +;; +;; ;; RUNS +;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) +;; (vector-ref (vector-ref rinfo 1) 3))) +;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) +;; +;; ;; TESTS +;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) +;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +;; (test "get keys" #t (list? (rmt:get-keys))) +;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) +;; (db:test-get-comment trec))) +;; +;; ;; MORE RUNS +;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) +;; (header (vector-ref runs 0)) +;; (data (vector-ref runs 1))) +;; (and (list? header) +;; (list? data) +;; (vector? (car data))))) +;; +;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) +;; +;; ;;====================================================================== +;; ;; D B +;; ;;====================================================================== +;; +;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) +;; (+ (db:test-get-pass_count dat) +;; (db:test-get-fail_count dat)))) +;; +;; (define testregistry (make-hash-table)) +;; (for-each +;; (lambda (tname) +;; (for-each +;; (lambda (itempath) +;; (let ((tkey (conc tname "/" itempath)) +;; (rpass (random 10)) +;; (rfail (random 10))) +;; (hash-table-set! testregistry tkey (list tname itempath)) +;; (rmt:general-call 'register-test 1 tname itempath) +;; (let* ((tid (rmt:get-test-id 1 tname itempath)) +;; (tdat (rmt:get-test-info-by-id tid))) +;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) +;; (let* ((resdat (rmt:get-test-info-by-id tid))) +;; (test "set/get pass fail counts" (list rpass rfail) +;; (list (db:test-get-pass_count resdat) +;; (db:test-get-fail_count resdat))))))) +;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) +;; (list "test1" "test2" "test3" "test4" "test5")) +;; +;; +;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) +;; + +(exit)