203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
+
-
-
-
+
+
+
+
|
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
(thread-sleep! 0.25)
(if (file-exists? fname)
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line)))))))
(with-input-from-file fname
(lambda ()
(equal? key-string (read-line))))
#f))))
(define (common:simple-file-release-lock fname)
(delete-file* fname))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
|
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
|
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
-
+
-
+
+
-
+
|
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (common:legacy-sync-recommended)
(or (args:get-arg "-runtests")
(args:get-arg "-server")
(args:get-arg "-set-run-status")
;; (args:get-arg "-set-run-status")
(args:get-arg "-remove-runs")
(args:get-arg "-get-run-status")
;; (args:get-arg "-get-run-status")
))
(define (common:legacy-sync-required)
(configf:lookup *configdat* "setup" "megatest-db"))
(define (std-exit-procedure)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(let ((run-ids (hash-table-keys *db-local-sync*)))
(if (and (not (null? run-ids))
(or (common:legacy-sync-recommended)
(configf:lookup *configdat* "setup" "megatest-db"))
(configf:lookup *configdat* "setup" "megatest-db")))
(if no-hurry (db:multi-db-sync run-ids 'new2old))))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *inmemdb* (db:close-all *inmemdb*))
(if (and *megatest-db*
(sqlite3:database? *megatest-db*))
(begin
(sqlite3:interrupt! *megatest-db*)
|