Megatest

Check-in [21a6dc94ac]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Cleaned up some calls to rpc procedures.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | rpc-db-access
Files: files | file ages | folders
SHA1: 21a6dc94ac713368ea81860b61f06fc7ee72016c
User & Date: matt on 2012-10-08 23:42:40
Other Links: branch diff | manifest | tags
Context
2012-10-08
23:42
Cleaned up some calls to rpc procedures. Closed-Leaf check-in: 21a6dc94ac user: matt tags: rpc-db-access
23:27
Minor improvement to server login messages check-in: 2b78b4fb41 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

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)
︙

This page was generated in about 0.11s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00