Megatest

Diff
Login

Differences From Artifact [f5e1ed9051]:

To Artifact [3b1178542b]:


1
2
3
4
5
6
7
8
9

;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

|







1
2
3
4
5
6
7
8
9

;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
491
492
493
494
495
496
497
498
499
500
501
502


503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
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
  (let ((dparts  (string-split dir "/"))
	(count   (if (null? params) 1 (car params))))
    (conc "/" (string-intersperse 
	       (take dparts (- (length dparts) count))
	       "/"))))
;; Remove runs
;; fields are passing in through 
(define (runs:remove-runs db runnamepatt testpatt itempatt)
  (let* ((keys        (rdb:get-keys db))
	 (rundat      (runs:get-runs-by-patt db keys runnamepatt))
	 (header      (vector-ref rundat 0))
	 (runs        (vector-ref rundat 1)))


    (debug:print 1 "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) "/"))
	     (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"))
			       (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '())
			       '()))
		(lasttpath "/does/not/exist/I/hope"))
	   (if (not (equal? run-state "locked"))
	       (begin
		 (if (not (null? tests))
		     (begin
		       (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
		       (for-each
			(lambda (test)
			  (let* ((item-path (db:test-get-item-path test))
				 (test-name (db:test-get-testname test))
				 (run-dir   (db:test-get-rundir test)))
			    (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
			    (rdb:delete-test-records db (db:test-get-id test))
			    (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
				(let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
				  (set! lasttpath fullpath)
				  (hash-table-set! dirs-to-remove fullpath #t)
				  ;; The following was the safe delete code but it was not being exectuted.
				  ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
				  ;;        (dir-to-rem (get-dir-up-n fullpath dirs-count))
				  ;;        (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
				  ;;        (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
				  ;;   (if (file-exists? fullpath)
				  ;;       (begin
				  ;;         (debug:print 1 cmd)
				  ;;         (system cmd)))
				  ;;   ))
				  ))))
			tests)))

		 ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
		 ;; for each test in case we get killed. That should minimize the detritus left on disk
		 ;; process the dirs from longest string length to shortest
		 (for-each 
		  (lambda (dir-to-remove)
		    (if (file-exists? dir-to-remove)
			(let ((dir-in-db '()))
			  (sqlite3:for-each-row
			   (lambda (dir)
			     (set! dir-in-db (cons dir dir-in-db)))
			   db "SELECT rundir FROM tests WHERE rundir LIKE ?;" 
			   (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
			  (if (null? dir-in-db)
			      (begin
				(debug:print 2 "Removing directory with zero db references: " dir-to-remove)
				(system (conc "rm -rf " dir-to-remove))
				(hash-table-delete! dirs-to-remove dir-to-remove))
			      (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
		  (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))

		 ;; remove the run if zero tests remain
		 (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
		   (if (null? remtests) ;; no more tests remaining
		       (let* ((dparts  (string-split lasttpath "/"))
			      (runpath (conc "/" (string-intersperse 
						  (take dparts (- (length dparts) 1))
						  "/"))))
			 (debug:print 1 "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
			 ;; 	 (debug:print 1 "Removing run dir " runpath)
			 ;; 	 (system (conc "rmdir -p " runpath))))
			 ))))
	       ))))
     runs)))

;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup 







|



|
>
>









|


|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
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
  (let ((dparts  (string-split dir "/"))
	(count   (if (null? params) 1 (car params))))
    (conc "/" (string-intersperse 
	       (take dparts (- (length dparts) count))
	       "/"))))
;; Remove runs
;; fields are passing in through 
(define (runs:remove-runs db runnamepatt testpatt itempatt #!key (state #f)(status #f))
  (let* ((keys        (rdb:get-keys db))
	 (rundat      (runs:get-runs-by-patt db keys runnamepatt))
	 (header      (vector-ref rundat 0))
	 (runs        (vector-ref rundat 1))
	 (states      (if state  (string-split state  ",") '()))
	 (statuses    (if status (string-split status ",") '())))
    (debug:print 1 "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) "/"))
	     (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"))
			       (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt states statuses not-in: #f)
			       '()))
		(lasttpath "/does/not/exist/I/hope"))


	   (if (not (null? tests))
	       (begin
		 (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
		 (for-each
		  (lambda (test)
		    (let* ((item-path (db:test-get-item-path test))
			   (test-name (db:test-get-testname test))
			   (run-dir   (db:test-get-rundir test)))
		      (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
		      (rdb:delete-test-records db (db:test-get-id test))
		      (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
			  (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
			    (set! lasttpath fullpath)
			    (hash-table-set! dirs-to-remove fullpath #t)
			    ;; The following was the safe delete code but it was not being exectuted.
			    ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
			    ;;        (dir-to-rem (get-dir-up-n fullpath dirs-count))
			    ;;        (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
			    ;;        (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
			    ;;   (if (file-exists? fullpath)
			    ;;       (begin
			    ;;         (debug:print 1 cmd)
			    ;;         (system cmd)))
			    ;;   ))
			    ))))
		    tests)))

	   ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
	   ;; for each test in case we get killed. That should minimize the detritus left on disk
	   ;; process the dirs from longest string length to shortest
	   (for-each 
	    (lambda (dir-to-remove)
	      (if (file-exists? dir-to-remove)
		  (let ((dir-in-db '()))
		    (sqlite3:for-each-row
		     (lambda (dir)
		       (set! dir-in-db (cons dir dir-in-db)))
		     db "SELECT rundir FROM tests WHERE rundir LIKE ?;" 
		     (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
		    (if (null? dir-in-db)
			(begin
			  (debug:print 2 "Removing directory with zero db references: " dir-to-remove)
			  (system (conc "rm -rf " dir-to-remove))
			  (hash-table-delete! dirs-to-remove dir-to-remove))
			(debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
	    (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))

	   ;; remove the run if zero tests remain
	   (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
	     (if (null? remtests) ;; no more tests remaining
		 (let* ((dparts  (string-split lasttpath "/"))
			(runpath (conc "/" (string-intersperse 
					    (take dparts (- (length dparts) 1))
					    "/"))))
		   (debug:print 1 "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
		   ;; 	 (debug:print 1 "Removing run dir " runpath)
		   ;; 	 (system (conc "rmdir -p " runpath))))
		   ))))
	 ))
     runs)))

;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup