Megatest

Check-in [f38b3dadbd]
Login
Overview
Comment:Merged in the removed based on state and status branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: f38b3dadbdc3bf1bbd7626a4b1935ff7c9303205
User & Date: mrwellan on 2012-04-04 19:41:50
Other Links: manifest | tags
Context
2012-04-09
15:45
Fixed issue with remove-runs so default is to remove all if :state and :status are not specified, fixed pattern match due to glob wierdness issue with running tests based on itempatt check-in: 2dca8d8f9a user: mrwellan tags: trunk
2012-04-04
19:41
Merged in the removed based on state and status branch check-in: f38b3dadbd user: mrwellan tags: trunk
18:07
Added ability to remove tests based on :state and :status Closed-Leaf check-in: 3ae695ed4b user: mrwellan tags: remove-given-state-status
17:30
Pulled in the beginings of multi-filter code check-in: 3e1180bef3 user: mrwellan tags: trunk
Changes

Modified db.scm from [a8d45b3634] to [41c48e20a6].

428
429
430
431
432
433
434

435
436
437
438
439
440
441
442
443
444
445
446
447
448
;;======================================================================
;;  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

(define (db:get-tests-for-run db run-id testpatt itempatt states statuses)
  (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 ") "
			 ;; " 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)))







>
|





|







428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
;;======================================================================
;;  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 #!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 " (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)))
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
  (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)
  (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)))

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







|




|
|







1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
  (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 #!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 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))

Modified megatest.scm from [ff47085649] to [0ed2270785].

253
254
255
256
257
258
259
260


261
262
263
264
265
266
267
	  (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")))


      (sqlite3:finalize! db)
      (set! *didsomething* #t)))))
	  
(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"







|
>
>







253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
	  (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")
			    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"

Modified runs.scm from [f5e1ed9051] to [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