562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
|
(begin
(debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header k)) keys) "/"))
(dirs-to-remove (make-hash-table)))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(tests (if (not (equal? run-state "locked"))
(cdb:remote-run db:get-tests-for-run db run-id
testpatt states statuses
not-in: #f
sort-by: (case action
((remove-runs) 'rundir)
(else 'event_time)))
'()))
(lasttpath "/does/not/exist/I/hope"))
(debug:print-info 4 "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((remove-runs)
(debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((set-state-status)
(debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((print-run)
(debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
(else
(debug:print-info 0 "action not recognised " action)))
(let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))
(dirb (db:test-get-rundir b)))
(if (and (string? dira)(string? dirb))
(> (string-length dira)(string-length dirb))
#f)))))
|
|
>
>
>
>
>
>
>
|
<
<
<
<
<
>
>
|
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
|
(begin
(debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header k)) keys) "/"))
(dirs-to-remove (make-hash-table))
(proc-get-tests (lambda (run-id)
(cdb:remote-run db:get-tests-for-run db run-id
testpatt states statuses
not-in: #f
sort-by: (case action
((remove-runs) 'rundir)
(else 'event_time))))))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(tests (if (not (equal? run-state "locked"))
(proc-get-tests run-id)
'()))
(lasttpath "/does/not/exist/I/hope"))
(debug:print-info 4 "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((remove-runs)
(debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((set-state-status)
(debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((print-run)
(debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
(debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
(else
(debug:print-info 0 "action not recognised " action)))
(let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))
(dirb (db:test-get-rundir b)))
(if (and (string? dira)(string? dirb))
(> (string-length dira)(string-length dirb))
#f)))))
|
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
|
(debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
(debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
))
(if (not (null? tal))
(loop (car tal)(cdr tal))))))
((set-state-status)
(debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
(cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)))))
)))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let ((remtests (cdb:remote-run db:get-tests-for-run db (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
|
|
>
>
>
>
>
>
>
|
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
|
(debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
(debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
))
(if (not (null? tal))
(loop (car tal)(cdr tal))))))
((set-state-status)
(debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
(cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))
((run-wait)
(debug:print-info 2 "still waiting, " (length tests) " tests still running")
(thread-sleep! 10)
(let ((new-tests (proc-get-tests run-id)))
(if (null? new-tests)
(debug:print-info 1 "Run completed according to zero tests matching provided criteria.")
(loop (car new-tests)(cdr new-tests))))))))
)))
;; remove the run if zero tests remain
(if (eq? action 'remove-runs)
(let ((remtests (cdb:remote-run db:get-tests-for-run db (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
|