1 1 2 ;; Copyright 2006-2012, Matthew Welland. | 2 ;; Copyright 2006-2011, Matthew Welland. 3 ;; 3 ;; 4 ;; This program is made available under the GNU GPL version 2.0 or 4 ;; This program is made available under the GNU GPL version 2.0 or 5 ;; greater. See the accompanying file COPYING for details. 5 ;; greater. See the accompanying file COPYING for details. 6 ;; 6 ;; 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 9 ;; PURPOSE. 9 ;; PURPOSE. ................................................................................................................................................................................ 491 (let ((dparts (string-split dir "/")) 491 (let ((dparts (string-split dir "/")) 492 (count (if (null? params) 1 (car params)))) 492 (count (if (null? params) 1 (car params)))) 493 (conc "/" (string-intersperse 493 (conc "/" (string-intersperse 494 (take dparts (- (length dparts) count)) 494 (take dparts (- (length dparts) count)) 495 "/")))) 495 "/")))) 496 ;; Remove runs 496 ;; Remove runs 497 ;; fields are passing in through 497 ;; fields are passing in through 498 (define (runs:remove-runs db runnamepatt testpatt itempatt) | 498 (define (runs:remove-runs db runnamepatt testpatt itempatt #!key (state #f)(stat 499 (let* ((keys (rdb:get-keys db)) 499 (let* ((keys (rdb:get-keys db)) 500 (rundat (runs:get-runs-by-patt db keys runnamepatt)) 500 (rundat (runs:get-runs-by-patt db keys runnamepatt)) 501 (header (vector-ref rundat 0)) 501 (header (vector-ref rundat 0)) 502 (runs (vector-ref rundat 1))) | 502 (runs (vector-ref rundat 1)) > 503 (states (if state (string-split state ",") '())) > 504 (statuses (if status (string-split status ",") '()))) 503 (debug:print 1 "Header: " header) 505 (debug:print 1 "Header: " header) 504 (for-each 506 (for-each 505 (lambda (run) 507 (lambda (run) 506 (let ((runkey (string-intersperse (map (lambda (k) 508 (let ((runkey (string-intersperse (map (lambda (k) 507 (db:get-value-by-header run head 509 (db:get-value-by-header run head 508 (dirs-to-remove (make-hash-table))) 510 (dirs-to-remove (make-hash-table))) 509 (let* ((run-id (db:get-value-by-header run header "id")) 511 (let* ((run-id (db:get-value-by-header run header "id")) 510 (run-state (db:get-value-by-header run header "state")) 512 (run-state (db:get-value-by-header run header "state")) 511 (tests (if (not (equal? run-state "locked")) 513 (tests (if (not (equal? run-state "locked")) 512 (rdb:get-tests-for-run db (db:get-value-by-header | 514 (rdb:get-tests-for-run db (db:get-value-by-header 513 '())) 515 '())) 514 (lasttpath "/does/not/exist/I/hope")) 516 (lasttpath "/does/not/exist/I/hope")) 515 (if (not (equal? run-state "locked")) < > 517 > 518 (if (not (null? tests)) 516 (begin 519 (begin 517 (if (not (null? tests)) < 518 (begin < 519 (debug:print 1 "Removing tests for run: " runkey " " (db: | 520 (debug:print 1 "Removing tests for run: " runkey " " (db:get-va 520 (for-each | 521 (for-each 521 (lambda (test) | 522 (lambda (test) 522 (let* ((item-path (db:test-get-item-path test)) | 523 (let* ((item-path (db:test-get-item-path test)) 523 (test-name (db:test-get-testname test)) | 524 (test-name (db:test-get-testname test)) 524 (run-dir (db:test-get-rundir test))) | 525 (run-dir (db:test-get-rundir test))) 525 (debug:print 1 " " (db:test-get-testname test) " id | 526 (debug:print 1 " " (db:test-get-testname test) " id: " (d 526 (rdb:delete-test-records db (db:test-get-id test)) | 527 (rdb:delete-test-records db (db:test-get-id test)) 527 (if (> (string-length run-dir) 5) ;; bad heuristic b | 528 (if (> (string-length run-dir) 5) ;; bad heuristic but sho 528 (let ((fullpath run-dir)) ;; "/" (db:test-get-it | 529 (let ((fullpath run-dir)) ;; "/" (db:test-get-item-pat 529 (set! lasttpath fullpath) | 530 (set! lasttpath fullpath) 530 (hash-table-set! dirs-to-remove fullpath #t) | 531 (hash-table-set! dirs-to-remove fullpath #t) 531 ;; The following was the safe delete code but | 532 ;; The following was the safe delete code but it was 532 ;; (let* ((dirs-count (+ 1 (length keys)(lengt | 533 ;; (let* ((dirs-count (+ 1 (length keys)(length (str 533 ;; (dir-to-rem (get-dir-up-n fullpath d | 534 ;; (dir-to-rem (get-dir-up-n fullpath dirs-co 534 ;; (remainingd (string-substitute (rege | 535 ;; (remainingd (string-substitute (regexp (co 535 ;; (cmd (conc "cd " dir-to-rem "; rmdir | 536 ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " 536 ;; (if (file-exists? fullpath) | 537 ;; (if (file-exists? fullpath) 537 ;; (begin | 538 ;; (begin 538 ;; (debug:print 1 cmd) | 539 ;; (debug:print 1 cmd) 539 ;; (system cmd))) | 540 ;; (system cmd))) 540 ;; )) | 541 ;; )) 541 )))) | 542 )))) 542 tests))) | 543 tests))) 543 544 544 ;; look though the dirs-to-remove for candidates for removal. D | 545 ;; look though the dirs-to-remove for candidates for removal. Do this 545 ;; for each test in case we get killed. That should minimize th | 546 ;; for each test in case we get killed. That should minimize the detr 546 ;; process the dirs from longest string length to shortest | 547 ;; process the dirs from longest string length to shortest 547 (for-each | 548 (for-each 548 (lambda (dir-to-remove) | 549 (lambda (dir-to-remove) 549 (if (file-exists? dir-to-remove) | 550 (if (file-exists? dir-to-remove) 550 (let ((dir-in-db '())) | 551 (let ((dir-in-db '())) 551 (sqlite3:for-each-row | 552 (sqlite3:for-each-row 552 (lambda (dir) | 553 (lambda (dir) 553 (set! dir-in-db (cons dir dir-in-db))) | 554 (set! dir-in-db (cons dir dir-in-db))) 554 db "SELECT rundir FROM tests WHERE rundir LIKE ?;" | 555 db "SELECT rundir FROM tests WHERE rundir LIKE ?;" 555 (conc "%" dir-to-remove "%")) ;; yes, I'm going to ba | 556 (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if 556 (if (null? dir-in-db) | 557 (if (null? dir-in-db) 557 (begin | 558 (begin 558 (debug:print 2 "Removing directory with zero db | 559 (debug:print 2 "Removing directory with zero db refere 559 (system (conc "rm -rf " dir-to-remove)) | 560 (system (conc "rm -rf " dir-to-remove)) 560 (hash-table-delete! dirs-to-remove dir-to-remove | 561 (hash-table-delete! dirs-to-remove dir-to-remove)) 561 (debug:print 2 "Skipping removal of " dir-to-remov | 562 (debug:print 2 "Skipping removal of " dir-to-remove " fo 562 (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string | 563 (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-lengt 563 564 564 ;; remove the run if zero tests remain | 565 ;; remove the run if zero tests remain 565 (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-head | 566 (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run 566 (if (null? remtests) ;; no more tests remaining | 567 (if (null? remtests) ;; no more tests remaining 567 (let* ((dparts (string-split lasttpath "/")) | 568 (let* ((dparts (string-split lasttpath "/")) 568 (runpath (conc "/" (string-intersperse | 569 (runpath (conc "/" (string-intersperse 569 (take dparts (- (length dparts | 570 (take dparts (- (length dparts) 1)) 570 "/")))) | 571 "/")))) 571 (debug:print 1 "Removing run: " runkey " " (db:get-valu | 572 (debug:print 1 "Removing run: " runkey " " (db:get-value-by-h 572 (db:delete-run db run-id) | 573 (db:delete-run db run-id) 573 ;; need to figure out the path to the run dir and remov | 574 ;; need to figure out the path to the run dir and remove it i 574 ;; (if (null? (glob (conc runpath "/*"))) | 575 ;; (if (null? (glob (conc runpath "/*"))) 575 ;; (begin | 576 ;; (begin 576 ;; (debug:print 1 "Removing run dir " runpath) | 577 ;; (debug:print 1 "Removing run dir " runpath) 577 ;; (system (conc "rmdir -p " runpath)))) | 578 ;; (system (conc "rmdir -p " runpath)))) 578 )))) | 579 )))) 579 )))) | 580 )) 580 runs))) 581 runs))) 581 582 582 ;;====================================================================== 583 ;;====================================================================== 583 ;; Routines for manipulating runs 584 ;; Routines for manipulating runs 584 ;;====================================================================== 585 ;;====================================================================== 585 586 586 ;; Since many calls to a run require pretty much the same setup 587 ;; Since many calls to a run require pretty much the same setup