︙ | | |
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
|
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
|
-
+
+
+
|
;; Ensure all tests are registered in the test_meta table
(runs:update-all-test_meta #f)
;; run the run prehook if there are no tests yet run for this run:
;;
(runs:run-pre-hook run-id)
;; mark all test launced flag as false in the meta table
(rmt:set-var (conc "lunch-complete-" run-id) "no")
(rmt:set-run-state-status run-id "new" "n/a")
;; now add non-directly referenced dependencies (i.e. waiton)
;;======================================================================
;; refactoring this block into tests:get-full-data
;;
;; What happended, this code is now duplicated in tests!?
;;
;;======================================================================
|
︙ | | |
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
|
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
|
-
-
-
-
-
-
+
+
+
+
+
+
|
(if (not (hash-table-ref/default flags "-rerun" #f))
(hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
;; recursive call to self
(runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
(debug:print-info 0 *default-log-port* "No tests to run")))
(debug:print-info 4 *default-log-port* "All done by here")
;; TODO: try putting post hook call here
(if (eq? run-count 0)
(begin
(debug:print-info 0 *default-log-port* "Calling Post Hook")
(debug:print-info 2 *default-log-port* " run-count " run-count)
(runs:run-post-hook run-id))
(debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))
;(if (eq? run-count 0)
; (begin
; (debug:print-info 0 *default-log-port* "Calling Post Hook")
; (debug:print-info 2 *default-log-port* " run-count " run-count)
; (runs:run-post-hook run-id))
; (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))
(rmt:tasks-set-state-given-param-key task-key "done")
;; (sqlite3:finalize! tasks-db)
))
;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
|
︙ | | |
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
|
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
|
+
+
-
+
|
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-8")
(debug:print-info 0 *default-log-port* "Have leftovers!")
(loop (car reg)(cdr reg) '() reruns))
(else
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-9")
(debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
))) ;; end loop on sorted test names
;; this is the point where everything is launced and now you can mark the run in metadata table as all launced
(rmt:set-var (conc "lunch-complete-" run-id) "yes")
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
(thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
(let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
(prev-num-running 0))
;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
(if (and (or (args:get-arg "-run-wait")
|
︙ | | |
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
|
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
|
-
+
+
+
+
|
(lambda (action)
(case action
((print)
(print " " (simple-run-runname run)
" " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S")
" " (if remove "REMOVE" "")))
((remove-runs)
(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"
(if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0
" -kill-wait 0"
"")))))
((archive)
(if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
((kill-runs)
(if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
))
actions))))
sorted)))
|
︙ | | |
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
|
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
|
-
+
|
(> (string-length dira)(string-length dirb))
#f))))))
(toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
(test-retry-time (make-hash-table))
(backgrounded-remove-status (make-hash-table))
(backgrounded-remove-last-visit (make-hash-table))
(backgrounded-remove-result (make-hash-table))
(allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em
(allow-run-time (string->number (or (args:get-arg "-kill-wait") "10")))) ;; seconds to allow for killing tests before just brutally killing 'em
(let loop ((test (car sorted-tests))
(tal (cdr sorted-tests)))
(let* ((test-id (db:test-get-id test))
(new-test-dat (rmt:get-test-info-by-id run-id test-id)))
(if (not new-test-dat)
(begin
(debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
|
︙ | | |
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
|
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
|
-
+
+
+
+
+
-
+
-
+
+
+
|
(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")))
(let ((run-id (db:get-value-by-header run header "id"))
(str (if lock
"lock"
"unlock")))
(if (or lock
(and unlock
(or (args:get-arg "-force")
(begin
(begin
(print "Do you really wish to unlock run " run-id "?\n y/n: ")
(equal? "y" (read-line)))))
(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))
(debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id))))
runs)))
;;======================================================================
;; Rollup runs
;;======================================================================
;; Update the test_meta table for this test
|
︙ | | |