397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
|
(args:get-arg "-use-db-cache") ;; feels like a bad idea ...
))
(define (common:legacy-sync-required)
(configf:lookup *configdat* "setup" "megatest-db"))
;; run-ids
;; if #f use *db-local-sync*
;; if #t use timestamps
(define (common:sync-to-megatest.db run-ids)
(let ((start-time (current-seconds))
(run-ids-to-process (if (list? run-ids)
run-ids
(if run-ids
(db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
(mtdb-exists (file-exists? mtdb-fpath)))
(if mtdb-exists
(file-modification-time mtdb-fpath)
0)))
(hash-table-keys *db-local-sync*)))))
(debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process)
|
|
|
|
|
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
|
(args:get-arg "-use-db-cache") ;; feels like a bad idea ...
))
(define (common:legacy-sync-required)
(configf:lookup *configdat* "setup" "megatest-db"))
;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
(define (common:sync-to-megatest.db run-ids)
(let ((start-time (current-seconds))
(run-ids-to-process (if (list? run-ids)
run-ids
(if (or (eq? run-ids 'timestamps)(eq? run-ids #t))
(db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
(mtdb-exists (file-exists? mtdb-fpath)))
(if mtdb-exists
(file-modification-time mtdb-fpath)
0)))
(hash-table-keys *db-local-sync*)))))
(debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process)
|
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
|
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
(if (common:low-noise-print 30 "sync new to old")
(debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
(hash-table-delete! *db-local-sync* run-id)))
(mutex-unlock! *db-multi-sync-mutex*))
run-ids-to-process)))
(define (std-exit-procedure)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
|
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
(if (common:low-noise-print 30 "sync new to old")
(debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
(hash-table-delete! *db-local-sync* run-id)))
(mutex-unlock! *db-multi-sync-mutex*))
run-ids-to-process)))
(define (common:watchdog)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:legacy-sync-required))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds)))
(if (or (common:legacy-sync-recommended)
legacy-sync)
(let loop ()
;; sync for filesystem local db writes
;;
(let ((start-time (current-seconds)))
(common:sync-to-megatest.db 'local-sync-flags)
(if (and debug-mode
(> (- start-time last-time) 60))
(begin
(set! last-time start-time)
(debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
(if (and (not *time-to-exit*)
(< count 4)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
(loop)))
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))
(define (std-exit-procedure)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
|