1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils z3) ;; (srfi 18) extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
|
|
>
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json
http-client directory-utils z3 srfi-18) ;; extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
|
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
(define (std-exit-procedure)
(rmt:print-db-stats)
(let ((run-ids (hash-table-keys *db-local-sync*)))
(if (not (null? run-ids))
(db:multi-db-sync run-ids 'new2old)))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
|
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog*
(make-thread
(lambda ()
(let loop ()
(thread-sleep! 5) ;; five second resolution is only a minor burden and should be tolerable
;; sync for filesystem local db writes
;;
(let ((start-time (current-seconds)))
(mutex-lock! *db-multi-sync-mutex*)
(for-each
(lambda (run-id)
(let ((last-write (hash-table-ref/default *db-local-sync* run-id 0)))
(if ;; (and
(> (- start-time last-write) 5) ;; every five seconds
;; (common:db-access-allowed?))
(begin
(db:multi-db-sync (list run-id) 'new2old)
(if (common:low-noise-print 30 "sync new to old")
(debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " (- (current-seconds) start-time) " seconds"))
(hash-table-delete! *db-local-sync* run-id)))))
(hash-table-keys *db-local-sync*))
(mutex-unlock! *db-multi-sync-mutex*))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(loop))))
"Watchdog thread"))
(thread-start! *watchdog*)
(define (std-exit-procedure)
(rmt:print-db-stats)
(let ((run-ids (hash-table-keys *db-local-sync*)))
(if (not (null? run-ids))
(db:multi-db-sync run-ids 'new2old)))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
|
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
|
;;======================================================================
(if *runremote* (close-all-connections!))
(if (not *didsomething*)
(debug:print 0 help))
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
(debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
(exit 0))
(case *globalexitstatus*
((0)(exit 0))
((1)(exit 1))
((2)(exit 2))
(else (exit 3)))))
|
>
>
>
|
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
|
;;======================================================================
(if *runremote* (close-all-connections!))
(if (not *didsomething*)
(debug:print 0 help))
(set! *time-to-exit* #t)
(thread-join! *watchdog*)
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
(debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
(exit 0))
(case *globalexitstatus*
((0)(exit 0))
((1)(exit 1))
((2)(exit 2))
(else (exit 3)))))
|