Megatest

Check-in [29cc9e826e]
Login
Overview
Comment:Added -set-state-status to enable setting state and status
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 29cc9e826eea5fbe6df76a2eddc147013c074ef2
User & Date: matt on 2012-04-12 00:55:32
Other Links: manifest | tags
Context
2012-04-12
16:14
Added helpful (hopefully) output on system and shell from config processing and launch processes check-in: b077e2bbcd user: mrwellan tags: trunk
00:55
Added -set-state-status to enable setting state and status check-in: 29cc9e826e user: matt tags: trunk
2012-04-11
17:38
Fixed patt-list-match failing on multi wild cards check-in: 205ca47739 user: mrwellan tags: trunk
Changes

Modified megatest.scm from [8aad599e04] to [c096f14df6].

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
  -itempatt patt          : in list-runs show only tests with items that match patt
  -showkeys               : show the keys used in this megatest setup
  -test-paths targpatt    : get the most recent test path(s) matching targpatt e.g. %/%... 
                            returns list sorted by age ascending, see examples below

Misc 
  -force                  : override some checks
  -remove-runs            : remove the data for a run, requires all fields be specified
                            and :runname ,-testpatt and -itempatt
                            and -testpatt
  -rerun FAIL,WARN...     : re-run if called on a test that previously ran (nullified
                            if -keepgoing is also specified)
  -rebuild-db             : bring the database schema up to date
  -rollup                 : fill run (set by :runname)  with latest test(s) from
                            prior runs with same keys
  -lock                   : lock the run specified by target and runname as locked
                            which prevents -remove-runs from removing the run
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh







|
|
|
|
<







79
80
81
82
83
84
85
86
87
88
89

90
91
92
93
94
95
96
  -itempatt patt          : in list-runs show only tests with items that match patt
  -showkeys               : show the keys used in this megatest setup
  -test-paths targpatt    : get the most recent test path(s) matching targpatt e.g. %/%... 
                            returns list sorted by age ascending, see examples below

Misc 
  -force                  : override some checks
  -remove-runs            : remove the data for a run, requires :runname, -testpatt and
                            -itempatt be set. Optionally use :state and :status
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
  -rerun FAIL,WARN...     : re-run if called on a test that previously ran

  -rebuild-db             : bring the database schema up to date
  -rollup                 : fill run (set by :runname)  with latest test(s) from
                            prior runs with same keys
  -lock                   : lock the run specified by target and runname as locked
                            which prevents -remove-runs from removing the run
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh
161
162
163
164
165
166
167

168
169
170
171
172
173
174
			":units"
			;; misc
			"-server"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"

			"-debug" ;; for *verbosity* > 2
			"-override-timeout"
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"







>







160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
			":units"
			;; misc
			"-server"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-override-timeout"
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
			"-repl"
			"-lock"
			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests
			"-remove-runs"
			"-keepgoing"
			"-usequeue"
			"-rebuild-db"
			"-rollup"
			"-update-meta"

			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only







<







182
183
184
185
186
187
188

189
190
191
192
193
194
195
			"-repl"
			"-lock"
			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests
			"-remove-runs"

			"-usequeue"
			"-rebuild-db"
			"-rollup"
			"-update-meta"

			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

258
259
260
261
262

263
264
265
266
267
268
269
270
271







272
273
274
275
276
277
278

;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (remove-runs)
  (cond
   ((not (args:get-arg ":runname"))
    (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt")
    (exit 2))
   ((not (args:get-arg "-testpatt"))
    (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the test pattern with -testpatt")
    (exit 3))
   ((not (args:get-arg "-itempatt"))
    (print "ERROR: Missing required parameter for -remove-runs, you must specify the items with -itempatt")
    (exit 4))
   ((let ((db #f))
      (if (not (setup-for-run))
	  (begin 
	    (debug:print 0 print "Failed to setup, exiting")
	    (exit 1)))
      (set! db (open-db))
;;       (if (not (args:get-arg "-server"))
;; 	  (server:client-setup db))
      (if (not (car *configinfo*))
	  (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"
     (lambda (db target runname keys keynames keyvallst)
       (remove-runs))))








;;======================================================================
;; Query runs
;;======================================================================

(if (args:get-arg "-list-runs")
    (let* ((db       (begin







|


|


|


|

<
<
<
<
|
<
<
<
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|






|
>
>
>
>
>
>
>







225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242




243



244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279

;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on db action)
  (cond
   ((not (args:get-arg ":runname"))
    (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt")
    (exit 2))
   ((not (args:get-arg "-testpatt"))
    (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt")
    (exit 3))
   ((not (args:get-arg "-itempatt"))
    (print "ERROR: Missing required parameter for " action ", you must specify the items with -itempatt")
    (exit 4))




   (else



    (if (not (car *configinfo*))
	(begin
	  (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found")
	  (exit 1))
	;; put test parameters into convenient variables
	(runs:operate-on  db
			  action
			  (args:get-arg ":runname")
			  (args:get-arg "-testpatt")
			  (args:get-arg "-itempatt")
			  state: (args:get-arg ":state") 
			  status: (args:get-arg ":status")
			  new-state-status: (args:get-arg "-set-state-status")))
    (sqlite3:finalize! db)
    (set! *didsomething* #t))))
	  
(if (args:get-arg "-remove-runs")
    (general-run-call 
     "-remove-runs"
     "remove runs"
     (lambda (db target runname keys keynames keyvallst)
       (operate-on db 'remove-runs))))

(if (args:get-arg "-set-state-status")
    (general-run-call 
     "-set-state-status"
     "set state and status"
     (lambda (db target runname keys keynames keyvallst)
       (operate-on db 'set-state-status))))

;;======================================================================
;; Query runs
;;======================================================================

(if (args:get-arg "-list-runs")
    (let* ((db       (begin

Modified runs.scm from [26fc9a5dca] to [757a50bdeb].

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
588
589
  (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
;;======================================================================








>
>
>
|
|
|
|
|
|
|
>
|














>
>
|
>
>
>
>






>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
|




>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
  (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 
;; action:
;;    'remove-runs
;;    'set-state-status
(define (runs:operate-on db action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-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 ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
    (debug:print 2 "Header: " header " action: " action " new-state-status: " new-state-status)
    (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
		 (case action
		   ((remove-runs)
		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   (else
		    (print "INFO: action not recognised " action)))
		 (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)
		      (case action
			((remove-runs)
			 (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)))
			       ;;   ))
			       )))
			((set-state-status)
			 (debug:print 4 "INFO: new state " (car state-status) ", new status " (cadr state-status))
			 (db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)))))
		  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
	   (if (eq? action 'remove-runs)
	       (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
	   (if (eq? action 'remove-runs)
	       (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
;;======================================================================

Modified tests/Makefile from [8a368d0627] to [13b200064d].

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
test2 : cleanprep
	$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b  $(SERVER) -debug 10

test3 : cleanprep
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER)

test4 : cleanprep
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) >& aa.log &
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) >& ab.log &
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) >& ac.log &
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -v $(SERVER) >& ad.log &	
	$(MEGATEST) -runtests runfirst -itempatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v
	$(MEGATEST) -runtests runfirst -itempatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10

cleanprep : ../*.scm Makefile *.config
	sqlite3 megatest.db "delete from metadat where var='SERVER';"
	mkdir -p /tmp/mt_runs /tmp/mt_links
	cd ..;make install







|
|
|
|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
test2 : cleanprep
	$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b  $(SERVER) -debug 10

test3 : cleanprep
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER)

test4 : cleanprep
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) 2&>1 aa.log &
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) 2&>1 ab.log &
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) 2&>1 ac.log &
	$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -v $(SERVER) 2&>1 ad.log &	
	$(MEGATEST) -runtests runfirst -itempatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v
	$(MEGATEST) -runtests runfirst -itempatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10

cleanprep : ../*.scm Makefile *.config
	sqlite3 megatest.db "delete from metadat where var='SERVER';"
	mkdir -p /tmp/mt_runs /tmp/mt_links
	cd ..;make install