Megatest

;;======================================================================
;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
(define (db:get-tests-for-run db run-id testpatt itempatt states statuses)
(define (db:get-tests-for-run db run-id testpatt itempatt states statuses #!key (not-in #t))
  (let* ((res '())
	 (states-str    (conc "('" (string-intersperse states   "','") "')"))
	 (statuses-str  (conc "('" (string-intersperse statuses "','") "')"))
	 (qry      (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment "
			 " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " 
			 " AND NOT (state in " states-str " AND status IN " statuses-str ") "
			 " AND " (if not-in "NOT" "") " (state in " states-str " AND status IN " statuses-str ") "
			 ;; " ORDER BY id DESC;"
			 " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id?
			 )))
    (debug:print 8 "INFO: db:get-tests-for-run qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))

  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-runs host port)
	 runnamepatt numruns startrunoffset keypatts))
      (db:get-runs db runnamepatt numruns startrunoffset keypatts)))

(define (rdb:get-tests-for-run db run-id testpatt itempatt states statuses)
(define (rdb:get-tests-for-run db run-id testpatt itempatt states statuses #!key (not-in #t))
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-tests-for-run host port)
	  run-id testpatt itempatt states statuses))
      (db:get-tests-for-run db run-id testpatt itempatt states statuses)))
	  run-id testpatt itempatt states statuses not-in: not-in))
      (db:get-tests-for-run db run-id testpatt itempatt states statuses not-in: not-in)))

(define (rdb:get-test-data-by-id db test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rpc:get-test-data-by-id host port)
	 test-id))

	  (begin
	    (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (runs:remove-runs db
			    (args:get-arg ":runname")
			    (args:get-arg "-testpatt")
			    (args:get-arg "-itempatt")))
			    (args:get-arg "-itempatt")
			    state: (args:get-arg ":state") 
			    status: (args:get-arg ":status")))
      (sqlite3:finalize! db)
      (set! *didsomething* #t)))))
	  
(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"

;; Copyright 2006-2012, Matthew Welland.
;; 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.

  (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)
(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)))
	 (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 '() '())
			       (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 (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)))
	   (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)))))
	   ;; 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))))
			 ))))
	       ))))
	   ;; 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