355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
|
(hash-table-delete! *waiting-queue* testname)))
(if (not db)
(sqlite3:finalize! ldb))))
waiting-test-names)
(sleep 10) ;; no point in rushing things at this stage?
(loop (hash-table-keys *waiting-queue*)))))))
(tests (db-get-tests-for-run db (db-get-value-by-header run header "id") testpatt itempatt)))
(if (not (null? tests))
(begin
(print "Removing tests for run: " runkey " " (db-get-value-by-header run header "runname"))
(for-each
(lambda (test)
(print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test))
(db:delete-test-records db (db:test-get-id test))
(if (> (string-length (db:test-get-rundir test)) 5) ;; bad heuristic but should prevent /tmp /home etc.
(let ((fullpath (db:test-get-rundir test))) ;; "/" (db:test-get-item-path test))))
(print "rm -rf " fullpath)
(system (conc "rm -rf " fullpath)))))
tests)
(let ((remtests (db-get-tests-for-run db (db-get-value-by-header run header "id"))))
(if (null? remtests) ;; no more tests remaining
(begin
(print "Removing run: " runkey " " (db-get-value-by-header run header "runname"))
(db:delete-run db run-id))))
)))))
runs)))
|
|
>
>
>
>
|
>
>
|
>
>
>
>
|
|
|
<
>
>
>
>
|
|
>
>
>
>
>
|
>
>
|
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
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
|
(hash-table-delete! *waiting-queue* testname)))
(if (not db)
(sqlite3:finalize! ldb))))
waiting-test-names)
(sleep 10) ;; no point in rushing things at this stage?
(loop (hash-table-keys *waiting-queue*)))))))
(define (get-dir-up-one dir)
(let ((dparts (string-split dir "/")))
(conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
;; Remove runs
;; fields are passing in through
(define (runs:remove-runs db runnamepatt testpatt itempatt)
(let* ((keys (db-get-keys db))
(rundat (runs:get-runs-by-patt db keys runnamepatt))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(print "Header: " header)
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db-get-value-by-header run header (vector-ref k 0))) keys) "/")))
(let* ((run-id (db-get-value-by-header run header "id") )
(tests (db-get-tests-for-run db (db-get-value-by-header run header "id") testpatt itempatt))
(lasttpath #f))
(if (not (null? tests))
(begin
(print "Removing tests for run: " runkey " " (db-get-value-by-header run header "runname"))
(for-each
(lambda (test)
(print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test))
(db:delete-test-records db (db:test-get-id test))
(if (> (string-length (db:test-get-rundir test)) 5) ;; bad heuristic but should prevent /tmp /home etc.
(let ((fullpath (db:test-get-rundir test))) ;; "/" (db:test-get-item-path test))))
(set! lasttpath fullpath)
(print "rm -rf " fullpath)
(system (conc "rm -rf " fullpath))
(let ((cmd (conc "rmdir -p " (get-dir-up-one fullpath))))
(print cmd)
(system cmd))
)))
tests)))
(let ((remtests (db-get-tests-for-run db (db-get-value-by-header run header "id"))))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
(print "Removing run: " runkey " " (db-get-value-by-header run header "runname"))
(db:delete-run db run-id)
;; need to figure out the path to the run dir and remove it if empty
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (print "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
)))
)))
runs)))
|