Changes In Branch rpc-db-access
Excluding Merge-Ins
This is equivalent to a diff from
2b78b4fb41
to 21a6dc94ac
Modified db.scm
from [606081fd7b]
to [d85eeb65b1].
︙ | | |
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
|
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
|
-
+
|
(list fail-count pass-count test-id))
*incoming-data*))
(mutex-unlock! *incoming-mutex*)
(if *cache-on*
(debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
(db:write-cached-data)))
(define (cdb:tests-register-test db run-id test-name item-path #!key (force-write #f))
(define (cdb:tests-register-test run-id test-name item-path #!key (force-write #f))
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(debug:print 4 "INFO: Adding " run-id ", " test-name "/" item-path " for setting pass/fail counts to the queue")
(mutex-lock! *incoming-mutex*)
(set! *last-db-access* (current-seconds))
(set! *incoming-data* (cons (vector 'register-test
|
︙ | | |
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
|
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
|
-
+
-
-
+
+
|
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
(cdb:pass-fail-counts test-id fail-count pass-count)))
;; currently forces a flush of the queue
(define (rdb:tests-register-test db run-id test-name item-path)
(define (rdb:tests-register-test run-id test-name item-path)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:tests-register-test host port) db run-id test-name item-path force-write: #t))
(cdb:tests-register-test db run-id test-name item-path force-write: #t)))
((rpc:procedure 'cdb:tests-register-test host port) run-id test-name item-path force-write: #t))
(cdb:tests-register-test run-id test-name item-path force-write: #t)))
(define (rdb:flush-queue)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:flush-queue host port)))
(cdb:flush-queue)))
|
Modified megatest.scm
from [e8b477af90]
to [6dc604ea96].
︙ | | |
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
|
-
+
+
|
(debug:print 0 "INFO: Starting the standalone server")
(if db
(let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!!
(th2 (server:start db (args:get-arg "-server")))
(th3 (make-thread (lambda ()
(server:keep-running db host:port)))))
(thread-start! th3)
(thread-join! th3))
(thread-join! th3)
(set! *didsomethings* #t))
(debug:print 0 "ERROR: Failed to setup for megatest"))))
;;======================================================================
;; full run
;;======================================================================
;; get lock in db for full run for this directory
|
︙ | | |
Modified runs.scm
from [260a499583]
to [0beb742b48].
︙ | | |
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
|
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
-
+
+
+
|
;; else the run is stuck, temporarily or permanently
;; but should check if it is due to lack of resources vs. prerequisites
(debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)
(thread-sleep! *global-delta*)
(if (not (null? tal))
(loop (car tal)(cdr tal) reruns)))
((not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f))
(open-run-close db:tests-register-test #f run-id test-name item-path)
;; (open-run-close db:tests-register-test #f run-id test-name item-path)
(rdb:tests-register-test run-id test-name item-path)
(rdb:flush-queue)
(hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t)
(thread-sleep! *global-delta*)
(loop (car newtal)(cdr newtal) reruns))
((not have-resources) ;; simply try again after waiting a second
(thread-sleep! (+ 1 *global-delta*))
(debug:print 1 "INFO: no resources to run new tests, waiting ...")
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
|
︙ | | |
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
|
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
|
-
+
+
+
|
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(set! test-id (open-run-close db:get-test-id db 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)
(open-run-close db:tests-register-test #f run-id test-name item-path)
;; (open-run-close db:tests-register-test #f run-id test-name item-path)
(rdb:tests-register-test run-id test-name item-path)
(rdb:flush-queue)
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))))
(debug:print 4 "INFO: test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (open-run-close db:get-test-info-by-id db test-id))))
(set! test-id (db:test-get-id testdat))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
|
︙ | | |
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
|
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
|
-
+
+
+
|
(debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
(db:test-get-run_duration testdat)))
600) ;; i.e. no update for more than 600 seconds
(begin
(debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
(tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
(tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)
;; (rdb:flush-queue)
)
(debug:print 2 "NOTE: " test-name " is already running")))
(else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
|
︙ | | |
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
|
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
|
-
-
-
+
+
+
+
|
(keys #f))
(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 (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers
(args:get-arg "-runtests")))
(server:client-setup)))
;;(if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers
;; (args:get-arg "-runtests")))
(server:client-setup))
;; )
(set! keys (open-run-close db:get-keys db))
;; 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 #f environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
|
︙ | | |