Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1128,11 +1128,11 @@ ;; we will need to process "all" messages here some day (rmsg sub-socket) ;; now get the actual message (set! res (db:string->obj (rmsg sub-socket)))))) (timeout (lambda () - (thread-sleep! 60) + (thread-sleep! 120) (if (not res) (if (> numretries 0) (begin (debug:print 0 "WARNING: no reply to query " params ", trying again") (apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params)) @@ -1230,15 +1230,17 @@ '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") )) ;; do not run these as part of the transaction -(define db:special-queries '(rollup-tests-pass-fail - db:roll-up-pass-fail-counts +(define db:special-queries '(;; rollup-tests-pass-fail + ;; db:roll-up-pass-fail-counts login immediate - flush)) + flush + set-verbosity + killserver)) ;; not used, intended to indicate to run in calling process (define db:run-local-queries '()) ;; rollup-tests-pass-fail)) ;; The queue is a list of vectors where the zeroth slot indicates the type of query to @@ -1315,12 +1317,23 @@ (hash-table-set! *logged-in-clients* client-key (current-seconds)) (server:reply pubsock return-address '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))) ((flush) (server:reply pubsock return-address '(#t "sucessful flush"))) + ((set-verbosity) + (set! *verbosity* (car params)) + (server:reply pubsock return-address '(#t *verbosity*))) + ((killserver) + (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") + (open-run-close tasks:server-deregister tasks:open-db + (cadr *server-info*) + pullport: (caddr *server-info*)) + (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) + (server:reply pubsock return-address '(#t "exit process started"))) (else - (debug:print 0 "ERROR: Unrecognised queued call " qry " " params))))) + (debug:print 0 "ERROR: Unrecognised queued call " qry " " params) + (server:reply pubsock return-address #t))))) (if (not (null? stmts)) (outerloop #f stmts))) ;; handle normal queries (let ((rem (sqlite3:with-transaction @@ -1370,15 +1383,11 @@ ;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) ;; (cdb:flush-queue *runremote*) (if (and (not (equal? item-path "")) - (or (equal? status "PASS") - (equal? status "WARN") - (equal? status "FAIL") - (equal? status "WAIVED") - (equal? status "RUNNING"))) + (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK"))) (begin (sqlite3:execute db "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), @@ -1389,14 +1398,20 @@ (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) (sqlite3:execute db "UPDATE tests - SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN - 'RUNNING' - ELSE 'COMPLETED' END, - status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END + SET state=CASE + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 'RUNNING' + ELSE 'COMPLETED' END, + status=CASE + WHEN fail_count > 0 THEN 'FAIL' + WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' + ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name)) #f) #f)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -130,11 +130,11 @@ (num-running (cdb:remote-run db:get-count-tests-running #f)) (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) - #f))) + 1))) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -240,10 +240,14 @@ (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (argv))))))) + +;;====================================================================== +;; C L I E N T S +;;====================================================================== (define (server:get-client-signature) (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) (set! *my-client-signature* sig) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -261,11 +261,12 @@ type ))) (cdb:remote-run db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (cdb:remote-run db:roll-up-pass-fail-counts #f run-id test-name item-path status) + (if (not (equal? item-path "")) + (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) @@ -272,11 +273,11 @@ (cdb:remote-run db:test-set-comment #f test-id cmt))) )) (define (tests:test-set-toplog! db run-id test-name logf) - (cdb:client-call *runremote* 'tests:test-set-toplog #t logf run-id test-name)) + (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name)) (define (tests:summarize-items db run-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -162,11 +162,11 @@ (file-exists? "nada.csh")))) (test #f #t (cdb:client-call *runremote* 'immediate #f 1 (lambda ()(display "Got here eh!?") #t))) ;; (set! *verbosity* 20) -(test #f *verbosity* (cdb:set-verbosity *runremote* *verbosity*)) +(test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*))) (test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS")) ;; (set! *verbosity* 1) ;; (cdb:set-verbosity *runremote* *verbosity*) (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) @@ -187,11 +187,11 @@ "myrun" "new" "n/a" "bob"))) -(test #f "CACHED" (cdb:tests-register-test *runremote* 1 "nada" "")) +(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)) (define keys (db:get-keys *db*)) @@ -309,17 +309,22 @@ (begin (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) ;; (exit) +(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1)) + +(test #f "dunno" (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS")) + ;;====================================================================== ;; R E M O T E C A L L S ;;====================================================================== (define start-wait (current-seconds)) (print "Starting intensive cache and rpc test") (for-each (lambda (params) + (print "Intensive: params=" params) (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") (apply cdb:test-set-status-state *runremote* test-id params) (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) (cdb:test-rollup-test_data-pass-fail *runremote* test-id) (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level @@ -361,33 +366,35 @@ ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("KILLED" "UNKNOWN" "More testing") )) + ;; now set all tests to completed (cdb:flush-queue *runremote*) (let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) (print "Setting " (length tests) " to COMPLETED/PASS") (for-each (lambda (test) (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) tests)) -(print "Waiting for server to be done, should be about 20 seconds") -(cdb:kill-server *runremote*) ;; (process-wait server-pid) -(test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) - (print "Server ran for " run-delta " seconds") - (> run-delta 20))) +;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) +;; (print "Server ran for " run-delta " seconds") +;; (> run-delta 20))) (test "Rollup the run(s)" #t (begin (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") #t)) (hash-table-set! args:arg-hash ":runname" "%") (test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) -(thread-join! th1 th2 th3) +(print "Waiting for server to be done, should be about 20 seconds") +(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 '() '())