| ︙ | | | ︙ | |
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
|
))
actions))))
sorted)))
;; (print "Sorted: " (map simple-run-event_time sorted))
;; (print "Remove: " (map simple-run-event_time to-remove))))
(hash-table-keys runs-ht))
runs-ht))
;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep)
;; (let ((data (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep)))
;; (for-each
;; (lambda (target)
;; (let ((runs-to-remove (hash-table-ref data target )))
;; (for-each
|
>
>
>
>
>
>
>
>
>
|
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
|
))
actions))))
sorted)))
;; (print "Sorted: " (map simple-run-event_time sorted))
;; (print "Remove: " (map simple-run-event_time to-remove))))
(hash-table-keys runs-ht))
runs-ht))
(define (remove-last-path-directory path-in)
(let* ((dparts (string-split path-in "/"))
(path-out (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
)
path-out
)
)
;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep)
;; (let ((data (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep)))
;; (for-each
;; (lambda (target)
;; (let ((runs-to-remove (hash-table-ref data target )))
;; (for-each
|
| ︙ | | | ︙ | |
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
|
(run-state (db:get-value-by-header run header "state"))
(run-name (db:get-value-by-header run header "runname"))
(tests (if (not (equal? run-state "locked"))
(proc-get-tests run-id)
'()))
(lasttpath "/does/not/exist/I/hope")
(lastrealpath "/does/not/exist/I/hope")
(worker-thread #f))
(debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((kill-runs)
(tasks:kill-runner target run-name "%")
|
>
>
|
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
|
(run-state (db:get-value-by-header run header "state"))
(run-name (db:get-value-by-header run header "runname"))
(tests (if (not (equal? run-state "locked"))
(proc-get-tests run-id)
'()))
(lasttpath "/does/not/exist/I/hope")
(lastrealpath "/does/not/exist/I/hope")
;; there may be a number of different disks used in the same run.
(run-paths-hash (make-hash-table))
(worker-thread #f))
(debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((kill-runs)
(tasks:kill-runner target run-name "%")
|
| ︙ | | | ︙ | |
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
|
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
(thread-sleep! 1)))
;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
(if (null? tal)
(loop new-test-dat tal)
(loop (car tal)(append tal (list new-test-dat)))))
(begin
(set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
(if (file-exists? lasttpath)
(set! lastrealpath (resolve-pathname lasttpath))
(set! lastrealpath lasttpath))
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
|
|
>
|
>
>
>
>
|
|
>
|
|
>
>
>
>
>
>
>
>
>
>
|
|
|
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
|
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
(thread-sleep! 1)))
;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
(if (null? tal)
(loop new-test-dat tal)
(loop (car tal)(append tal (list new-test-dat)))))
(begin
(let ((rundir (db:test-get-rundir new-test-dat)))
(if (and (not (string= rundir "/tmp/badname"))
(file-exists? rundir)
(substring-index run-name rundir)
(substring-index target rundir)
)
(begin
(set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
(set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath)))
(hash-table-set! run-paths-hash lastrealpath 1)
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
)
(begin
(debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
(debug:print 2 *default-log-port* "Is /tmp/badname: " (string= rundir "/tmp/badname"))
(debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))
(debug:print 2 *default-log-port* "Has run-name: " (substring-index run-name rundir))
(debug:print 2 *default-log-port* "Has target: " (substring-index target rundir))
)
)
)
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
((kill-runs)
;; RUNNING -> KILLREQ
;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
(cond
((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
(common:send-thunk-to-background-thread
|
| ︙ | | | ︙ | |
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
|
(common:join-backgrounded-threads))))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let* ((run-id (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
(remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
;; Remove the last dir from the path.
;; And same for the link-resolved path
(let* ((dparts (string-split lasttpath "/"))
(linkspath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
(real-dparts (string-split lastrealpath "/"))
(realpath (conc "/" (string-intersperse (take real-dparts (- (length real-dparts) 1)) "/")))
)
(debug:print 1 *default-log-port* "Removing run: " linkspath)
(if (not keep-records)
(begin
(debug:print 1 *default-log-port* "Removing DB records for the run.")
(rmt:delete-run run-id)
(rmt:delete-old-deleted-test-records))
)
(debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
(runs:recursive-delete-with-error-msg linkspath)
(debug:print 1 *default-log-port* "Recursively removing real dir " realpath)
(runs:recursive-delete-with-error-msg realpath)
)))))
))
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))
)
|
|
|
<
<
<
<
|
>
>
|
|
|
|
|
|
|
|
|
>
|
|
|
>
>
|
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
|
(common:join-backgrounded-threads))))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let* ((run-id (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
(remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
(let* ((linkspath (remove-last-path-directory lasttpath))
(runpaths (hash-table-keys run-paths-hash))
)
(debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash))
(debug:print 1 *default-log-port* "Removing target " target "run: " run-name)
(if (not keep-records)
(begin
(debug:print 1 *default-log-port* "Removing DB records for the run.")
(rmt:delete-run run-id)
(rmt:delete-old-deleted-test-records))
)
(debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
(runs:recursive-delete-with-error-msg linkspath)
(for-each (lambda(runpath)
(debug:print 1 *default-log-port* "Recursively removing runs dir " runpath)
(runs:recursive-delete-with-error-msg runpath)
)
runpaths
)
)))))
))
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))
)
|
| ︙ | | | ︙ | |
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
|
(define doc-template
'(*TOP*
(*PI* xml "version='1.0'")
(testsuite)))
(define (runs:update-junit-test-reporter-xml run-id)
(let* (
(junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
(junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
(xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
(if junit-test-report-dir
junit-test-report-dir
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
#f))
(xml-ts-name (if xml-dir
(conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
#f))
(keyname (common:get-signature xml-ts-name))
(xml-path (if xml-dir
(conc xml-dir "/" keyname ".xml")
#f))
(test-data (if xml-dir
(rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
#f #f ;; offset limit
|
|
|
|
|
|
|
|
>
>
|
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
|
(define doc-template
'(*TOP*
(*PI* xml "version='1.0'")
(testsuite)))
(define (runs:update-junit-test-reporter-xml run-id)
(let* (
(junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
(junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
(xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
(if junit-test-report-dir
junit-test-report-dir
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
#f))
(xml-ts-name (if xml-dir
(conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
#f))
(keyname (if xml-ts-name
(common:get-signature xml-ts-name)
#f))
(xml-path (if xml-dir
(conc xml-dir "/" keyname ".xml")
#f))
(test-data (if xml-dir
(rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
#f #f ;; offset limit
|
| ︙ | | | ︙ | |
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
|
(test-itempath (vector-ref test 11))
(tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
(test-state (vector-ref test 3))
(comment (vector-ref test 14))
(test-status (vector-ref test 4))
(exc-msg (conc "No bucket for State " test-state " Status " test-status))
(new-doc (cond
((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "RUNNING" ))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress (@ (type "inProgress")))))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
((member test-status (list "SKIP"))
|
>
>
|
|
|
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
|
(test-itempath (vector-ref test 11))
(tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
(test-state (vector-ref test 3))
(comment (vector-ref test 14))
(test-status (vector-ref test 4))
(exc-msg (conc "No bucket for State " test-state " Status " test-status))
(new-doc (cond
((member test-state (list "RUNNING" ))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress (@ (type "inProgress")))))) doc))
((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress (@ (type "inQueue")))))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
((member test-status (list "SKIP"))
|
| ︙ | | | ︙ | |