Megatest

Changes On Branch remove-given-state-status
Login

Changes In Branch remove-given-state-status Excluding Merge-Ins

This is equivalent to a diff from c65398ee68 to 3ae695ed4b

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
2012-03-31
18:38
Cleaned up ignores and added minimal example to docs check-in: ca3478ee5c user: matt tags: trunk
18:26
Experimentally cutting back the open-db/finalize cycle NOTE: This made contention on the db worse and causes failures Closed-Leaf check-in: e01e81f554 user: matt tags: experimental-streamlining
2012-03-30
00:07
Fixed reading of runconfigs; chdir to location of .config before reading sub-files; added pattern matching on sections to target; added tests, removed some redundant db accesses check-in: c65398ee68 user: matt tags: trunk
2012-03-28
20:16
Removed debug statement check-in: aea23d28f1 user: mrwellan tags: trunk

Modified db.scm from [1ae5c33688] to [f62d133081].

422
423
424
425
426
427
428

429
430
431
432
433
434
435
436
437
438
439
440
441
442
;;======================================================================
;;  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)))







>
|





|







422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
;;======================================================================
;;  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)))
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
  (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))







|




|
|







1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
  (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 [f3f42fd5f0] to [77a84de5f2].

250
251
252
253
254
255
256
257


258
259
260
261
262
263
264
	  (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"







|
>
>







250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
	  (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 [eb30591b86] to [e177dce855].

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

		(tests  (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
		(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)







|



|
>
>







>
|







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
  (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") )
		;; not-in: switches from the default get-tests-for-run behavior to require a match
		(tests  (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)