| ︙ | | |
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
-
+
|
;; to-soon delay, when matching event happened in less than dseconds delay wseconds
;;
(define (runs:too-soon-delay key dseconds wseconds)
(let* ((last-time (hash-table-ref/default *too-soon-delays* key #f)))
(if (and last-time
(< (- (current-seconds) last-time) dseconds))
(begin
(debug:print-info 0 *default-log-port* "Whoa, slow down there ... "key" has been too recently seen.")
(debug:print-info 4 *default-log-port* "Whoa, slow down there ... "key" has been too recently seen.")
(thread-sleep! wseconds)))
(hash-table-set! *too-soon-delays* key (current-seconds))))
(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
;; Take advantage of a good place to exit if running the one-pass methodology
(if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
|
| ︙ | | |
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
-
+
-
+
|
;(set! run-count config-reruns))
;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(bdat-time-to-exit-set! *bdat* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
;; (let ((tdbdat (tasks:open-db)))
(rmt:tasks-set-state-given-param-key task-key "killed") ;; )
(print "Killed by signal " signum ". Exiting")
(debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting")
(thread-sleep! 3)
(exit))))
(th2 (make-thread (lambda ()
(thread-sleep! 5)
(debug:print 0 *default-log-port* "Done")
(exit 4)))))
(thread-start! th2)
|
| ︙ | | |
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
|
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
|
-
+
|
(not (and prevdat
(equal? state (db:test-get-state prevdat))
(equal? status (db:test-get-status prevdat)))))
(let ((fmt (runs:gendat-inc-results-fmt runs-data))
(dtime (seconds->year-work-week/day-time event-time)))
(if (runs:lownoise "inc-print" 600)
(begin
(print "fmt=" fmt)
;; (print "fmt=" fmt)
(format #t fmt "State" "Status" "Start Time" "Duration" "Test path")))
;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime)
;; (debug:print 0 #f "event-time: " event-time " duration: " duration)
(format #t fmt
state
status
dtime
|
| ︙ | | |
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
|
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
|
-
+
|
(begin
;; wait for less than max jobs here
(if (runs:dat-wait-for-jobs-function runsdat)
((runs:dat-wait-for-jobs-function runsdat) testdat-rec))
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(debug:print 0 *default-log-port* "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))
)
;; wait again here?
))))))
((KILLED)
(debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
|
| ︙ | | |
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
|
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
|
-
+
+
+
-
+
|
runs)))
targets)
res-ht))
;; delete runs older than X (weeks, days, months years etc.)
;; delete redundant runs within a target - N is the input
;; delete redundant runs within a target IFF older than given date/time AND keep at least N
;;
;;
;; QUESTION: Should the (print ... be (debug:print ... or not?
;;
(define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print)))
(let* ((runs-ht (runs:get-hash-by-target target-patts runpatt))
(age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f))
(age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400)))
(precmd (or (args:get-arg "-precmd") ""))
(action-chk (member (string->symbol "remove-runs") actions)))
;; check the sequence of actions archive must comme before remove-runs
(if (and action-chk (member (string->symbol "archive") action-chk))
(begin
(debug:print-error 0 *default-log-port* "action remove-runs must come after archive")
(exit 1)))
(print "Actions: " actions " age: " age)
(debug:print-info 0 *default-log-port* "Actions: " actions " age: " age)
(for-each
(lambda (action)
(for-each
(lambda (target)
(let* ((runs (hash-table-ref runs-ht target))
(sorted (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b)))))
(to-remove (let* ((len (length sorted))
|
| ︙ | | |
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
|
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
|
-
+
-
+
|
))
runs)
;; special case - archive get
(if (equal? (args:get-arg "-archive") "get")
(archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex))
(if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove"))
(begin
(print "db archive started")
(debug:print 0 *default-log-port* "db archive started")
(archive:megatest-db target runnamepatt)
(print "db archived")))
(debug:print 0 *default-log-port* "db archived")))
)
#t
)
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
|
| ︙ | | |
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
|
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
|
-
-
-
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
|
(define (runs:handle-locking target keys runname lock unlock user)
(let* ((db #f)
(rundat (mt:get-runs-by-patt keys runname target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(for-each (lambda (run)
(let ((run-id (db:get-value-by-header run header "id"))
(str (if lock
"lock"
"unlock")))
(begin
(print "Do you really wish to unlock run " run-id "?\n y/n: ")
(equal? "y" (read-line))))))
(begin
(rmt:lock/unlock-run run-id lock unlock user)
(debug:print-info 0 *default-log-port* "Done " str " on run id " run-id))
|
| ︙ | | |
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
|
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
|
-
+
|
(target-patt (if (args:get-arg "-target-patt")
(args:get-arg "-target-patt")
"%"))
(run-times (rmt:get-run-times run-patt target-patt )))
(if (eq? (length run-times) 0)
(begin
(print "Data not found!!")
(debug:print 0 *default-log-port* "Data not found!!")
(exit)))
(if (equal? (args:get-arg "-dumpmode") "json")
(task:print-runtime-as-json run-times)
(if (equal? (args:get-arg "-dumpmode") "csv")
(task:print-runtime run-times ",")
(task:print-runtime run-times " ")))))
)
|