Megatest

Check-in [706a4ef570]
Login
Overview
Comment:Changed register-test to do a flush immediately
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | test-specific-db
Files: files | file ages | folders
SHA1: 706a4ef57078c3f960bc649911bb91d2b9b2a85e
User & Date: mrwellan on 2012-10-05 16:38:33
Other Links: branch diff | manifest | tags
Context
2012-10-05
17:04
Backed out rpc of register-test, test1,test4 working check-in: 197b642483 user: mrwellan tags: test-specific-db
16:38
Changed register-test to do a flush immediately check-in: 706a4ef570 user: mrwellan tags: test-specific-db
16:25
rpc updates, test1 passes check-in: 105f6a0b2b user: mrwellan tags: test-specific-db
Changes

Modified db.scm from [ae0415f972] to [d1723d75e5].

1071
1072
1073
1074
1075
1076
1077
1078

1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090

1091
1092
1093
1094
1095
1096
1097
1071
1072
1073
1074
1075
1076
1077

1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089

1090
1091
1092
1093
1094
1095
1096
1097







-
+











-
+







				      (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 run-id test-name item-path)
(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
					(current-milliseconds)
					(list run-id test-name item-path)) ;; fail-count pass-count test-id))
				*incoming-data*))
    (mutex-unlock! *incoming-mutex*)
    (if *cache-on*
    (if (and (not force-write) *cache-on*)
	(debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
	(db:write-cached-data))))

;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;
1645
1646
1647
1648
1649
1650
1651

1652
1653
1654
1655
1656
1657


1658
1659
1660
1661
1662
1663
1664
1665
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656


1657
1658
1659
1660
1661
1662
1663
1664
1665
1666







+




-
-
+
+








(define (rdb:pass-fail-counts test-id fail-count pass-count)
  (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 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) run-id test-name item-path))
      (cdb:tests-register-test run-id test-name item-path)))
	((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 runs.scm from [3275d39bce] to [2817b1bec2].

613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
613
614
615
616
617
618
619

620
621
622
623
624
625
626







-







	    ;; 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)
		  (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