Overview
| Comment: | Added simple lock to on-exit call of sync to megatest.db. Set lots of vars when triggers are called. |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.60-zero-local-access |
| Files: | files | file ages | folders |
| SHA1: |
2bae638e0f9fb761db7d23313f930ba4 |
| User & Date: | matt on 2015-11-11 22:58:46 |
| Other Links: | branch diff | manifest | tags |
Context
|
2015-11-11
| ||
| 23:00 | Merging in v1.60-zero-local-access to v1.60 Closed-Leaf check-in: c6c921401e user: matt tags: v1.60-zero-local-access | |
| 22:58 | Added simple lock to on-exit call of sync to megatest.db. Set lots of vars when triggers are called. check-in: 2bae638e0f user: matt tags: v1.60-zero-local-access | |
| 22:28 | Added back sync'ing to megatest.db but with simple file locking and much longer delay check-in: 29908b23ed user: matt tags: v1.60-zero-local-access | |
Changes
Modified common.scm from [6b9cb42343] to [2d3a0413db].
| ︙ | ︙ | |||
282 283 284 285 286 287 288 | (define (std-exit-procedure) ;; (let ((dbpath (db:dbfile-path run-id)) ;; (lockf (conc dbpath "/." run-id ".lck"))) ;; (common:simple-file-lock lockf) ;; (db:multi-db-sync (list run-id) 'new2old) ;; (common:simple-file-release-lock lockf)) | | | | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
(define (std-exit-procedure)
;; (let ((dbpath (db:dbfile-path run-id))
;; (lockf (conc dbpath "/." run-id ".lck")))
;; (common:simple-file-lock lockf)
;; (db:multi-db-sync (list run-id) 'new2old)
;; (common:simple-file-release-lock lockf))
(let* ((dbpath (db:dbfile-path #f))
(lockf (conc dbpath "/.megatest.lck"))
(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))
|
| ︙ | ︙ |
Modified megatest.scm from [a6b3a87608] to [c312c4165d].
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
(make-thread
(lambda ()
(thread-sleep! 0.05) ;; delay for startup
| | | | > > | | > > | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
(make-thread
(lambda ()
(thread-sleep! 0.05) ;; delay for startup
(let* ((legacy-sync (common:legacy-sync-required))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(dbpath (db:dbfile-path #f))
(lockf (conc dbpath "/.megatest.lck")))
(if (or legacy-sync
(common:legacy-sync-recommended)) ;; for now do *some* syncing to megatest.db for backup purposes
(let loop ()
;; sync for filesystem local db writes
;;
(let ((start-time (current-seconds))
(servers-started (make-hash-table)))
(for-each
(lambda (run-id)
(mutex-lock! *db-multi-sync-mutex*)
(if (and legacy-sync
(hash-table-ref/default *db-local-sync* run-id #f))
;; (if (> (- start-time last-write) 5) ;; every five seconds
(begin ;; let ((sync-time (- (current-seconds) start-time)))
(common:simple-file-lock lockf)
(db:multi-db-sync (list run-id) 'new2old)
(common:simple-file-release-lock lockf)
(if (common:low-noise-print 30 "sync new to old")
(let ((sync-time (- (current-seconds) start-time)))
(debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
;; (begin
;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
;; (server:kind-run run-id)))))
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 | (debug:print-info 4 "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*) | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
(debug:print-info 4 "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 40)) ;; aprox 30-40 seconds
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
(loop)))
(if (common:low-noise-print 30)
(debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))
"Watchdog thread")))
|
| ︙ | ︙ |
Modified mt.scm from [d7eb2f40fc] to [3fc7d68694].
| ︙ | ︙ | |||
143 144 145 146 147 148 149 150 151 152 153 154 155 156 | (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) (lambda () (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let ((cmd (configf:lookup tconfig "triggers" trigger)) (logf (conc test-rundir "/last-trigger.log"))) (if cmd ;; Putting the commandline into ( )'s means no control over the shell. | > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) (lambda () (runs:set-megatest-env-vars run-id) ;;; WARNING: This sets a lot of vars!!!! (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let ((cmd (configf:lookup tconfig "triggers" trigger)) (logf (conc test-rundir "/last-trigger.log"))) (if cmd ;; Putting the commandline into ( )'s means no control over the shell. |
| ︙ | ︙ |