Megatest

Check-in [51ca0f283a]
Login
Overview
Comment:Add flushing of the cache when cached? is #f
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | monitor-cleanup
Files: files | file ages | folders
SHA1: 51ca0f283a22098d4bf61cd5f86cd056614246ea
User & Date: mrwellan on 2012-10-29 15:41:14
Other Links: branch diff | manifest | tags
Context
2012-10-29
22:40
Got 98% of wb tests clean. check-in: c962fdaa66 user: matt tags: monitor-cleanup
15:41
Add flushing of the cache when cached? is #f check-in: 51ca0f283a user: mrwellan tags: monitor-cleanup
13:26
migrated test-set-run-dir check-in: bbc91026be user: mrwellan tags: monitor-cleanup
Changes

Modified db.scm from [c0e24db4b7] to [9b96a65b63].

981
982
983
984
985
986
987
988

989
990
991
992
993
994
995
996
997
998
999
1000
1001
981
982
983
984
985
986
987

988






989
990
991
992
993
994
995







-
+
-
-
-
-
-
-







	   db 
	   "SELECT rundir FROM tests WHERE id=?;"
	   test-id)
	  (hash-table-set! *test-paths* test-id res)
	  res))))

(define (cdb:test-set-log! zmqsocket test-id logf)
  (if (string? logf)(cdb:client-call zmqsocket 'test-set-log #t test-id logf)))
  (if (string? logf)(cdb:client-call zmqsocket 'test-set-log #f test-id logf)))

;; (define (db:test-set-log! db test-id logf)
;;   (if (string? logf)
;;       (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;"
;; 		       logf test-id)
;;       (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf)))

;;======================================================================
;; Misc. test related queries
;;======================================================================

(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
  (let* ((testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107






1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120

1121
1122
1123
1124
1125
1126
1127
1089
1090
1091
1092
1093
1094
1095






1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122







-
-
-
-
-
-
+
+
+
+
+
+













+







    res))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS
;;======================================================================

;; db:updater is run in a thread to write out the cached data periodically
(define (db:updater)
  (debug:print-info 4 "Starting cache processing")
  (let loop ()
    (thread-sleep! 10) ;; move save time around to minimize regular collisions?
    (db:write-cached-data)
    (loop)))
;; (define (db:updater)
;;   (debug:print-info 4 "Starting cache processing")
;;   (let loop ()
;;     (thread-sleep! 10) ;; move save time around to minimize regular collisions?
;;     (db:write-cached-data)
;;     (loop)))

;; cdb:cached-access is called by the server loop to dispatch commands or queue up
;; db accesses
;;
;; params := qry-name cached? val1 val2 val3 ...
(define (cdb:cached-access params)
  (debug:print-info 12 "cdb:cached-access params=" params)
  (if (< (length params) 2)
      "ERROR"
      (let ((qry-name (car params))
	    (cached?  (cadr params))
	    (remparam (list-tail params 2))) 
	(debug:print-info 12 "cdb:cached-access qry-name=" qry-name " params=" params)
	(if (not cached?)(db:write-cached-data))
	;; Any special calls are dispatched here. 
	;; Remainder are put in the db queue
	(case qry-name
	  ((login) ;; login checks that the megatest path matches
	   (if (null? remparam)
	       #f ;; no path - fail!
	       (let ((calling-path (car remparam)))

Modified server.scm from [7f76fb460f] to [ea850546f4].

179
180
181
182
183
184
185
186

187
188
189
190
191
192
193
179
180
181
182
183
184
185

186
187
188
189
190
191
192
193







-
+







    (if *toppath* 
	(let* ((th2 (make-thread (lambda ()
				   (server:run (args:get-arg "-server")))))
	       (th3 (make-thread (lambda ()
				   (server:keep-running)))))
	  (thread-start! th3)
	  (thread-start! th2)
	  (thread-join! th3)
	  (thread-join! th2)
	  (set! *didsomething* #t))
	(debug:print 0 "ERROR: Failed to setup for megatest"))))

(define (server:client-launch)
  (if (server:client-setup)
      (debug:print-info 0 "connected as client")
      (begin