166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(db:multi-db-sync
#f ;; do all run-ids
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
;; 'old2new
'new2old)
(if (common:version-changed?)
(common:set-last-run-version)))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
|
|
>
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
(db:multi-db-sync
#f ;; do all run-ids
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
;; 'old2new
'new2old
'schema)
(if (common:version-changed?)
(common:set-last-run-version)))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
|
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
|
(define (common:legacy-sync-recommended)
(or (args:get-arg "-runtests")
(args:get-arg "-server")
;; (args:get-arg "-set-run-status")
(args:get-arg "-remove-runs")
;; (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 *default-log-port* "starting exit process, finalizing databases.")
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
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
|
(define (common:legacy-sync-recommended)
(or (args:get-arg "-runtests")
(args:get-arg "-server")
;; (args:get-arg "-set-run-status")
(args:get-arg "-remove-runs")
;; (args:get-arg "-get-run-status")
(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)
(for-each
(lambda (run-id)
(mutex-lock! *db-multi-sync-mutex*)
(if (or run-ids ;; if we were provided with run-ids, proceed
(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)))
(db:multi-db-sync (list run-id) 'new2old)
(let ((sync-time (- (current-seconds) start-time)))
(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))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
|
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
|
;; ((CHECK) "255 100 50")
;; ((REMOTEHOSTSTART) "50 130 195")
;; ((RUNNING) "9 131 232")
;; ((KILLREQ) "39 82 206")
;; ((KILLED) "234 101 17")
;; ((NOT_STARTED) "240 240 240")
;; (else "192 192 192")))
(define (common:get-color-from-status status)
(cond
((equal? status "PASS") "green")
((equal? status "FAIL") "red")
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
|
>
>
>
>
>
>
>
>
|
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
|
;; ((CHECK) "255 100 50")
;; ((REMOTEHOSTSTART) "50 130 195")
;; ((RUNNING) "9 131 232")
;; ((KILLREQ) "39 82 206")
;; ((KILLED) "234 101 17")
;; ((NOT_STARTED) "240 240 240")
;; (else "192 192 192")))
(define (common:iup-color->rgb-hex instr)
(string-intersperse
(map (lambda (x)
(number->string x 16))
(map string->number
(string-split instr)))
"/"))
(define (common:get-color-from-status status)
(cond
((equal? status "PASS") "green")
((equal? status "FAIL") "red")
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
|