Megatest

Check-in [99f24d81d1]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added ability to clean tests and launch from the gui. Also added filter for running from command line -itempatt is now respected by -runtests with % as wildcard
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 99f24d81d1116f22a371dec330da93214796e802
User & Date: matt on 2011-09-25 23:46:08
Other Links: manifest | tags
Context
2011-09-26
00:11
Added install of mt_* scripts check-in: cd3d02e58e user: matt tags: trunk
2011-09-25
23:46
Added ability to clean tests and launch from the gui. Also added filter for running from command line -itempatt is now respected by -runtests with % as wildcard check-in: 99f24d81d1 user: matt tags: trunk
18:54
Fixed sorting issue on steps in dashboard check-in: 89b1a10150 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard-tests.scm from [a7e217ed51] to [939dbd59fd].

︙︙
243
244
245
246
247
248
249







250
251
252
253
254
255
256

	 (rundir        logfile)
	 (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	 (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	 (testmeta      (if testdat 
			    (let ((tm (db:testmeta-get-record db testname)))
			      (if tm tm (make-db:testmeta)))
			    (make-db:testmeta)))







	 (viewlog    (lambda (x)
		       (if (file-exists? logfile)
			   ;(system (conc "firefox " logfile "&"))
			   (iup:send-url logfile)
			   (message-window (conc "File " logfile " not found")))))
	 (xterm      (lambda (x)
		       (if (directory-exists? rundir)








>
>
>
>
>
>
>








243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263

	 (rundir        logfile)
	 (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	 (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	 (testmeta      (if testdat 
			    (let ((tm (db:testmeta-get-record db testname)))
			      (if tm tm (make-db:testmeta)))
			    (make-db:testmeta)))

	 (keystring  (string-intersperse 
		      (map (lambda (keyval)
			     (conc ":" (car keyval) " " (cadr keyval)))
			   keydat)
		      " "))
	 (item-path  (db:test-get-item-path testdat))
	 (viewlog    (lambda (x)
		       (if (file-exists? logfile)
			   ;(system (conc "firefox " logfile "&"))
			   (iup:send-url logfile)
			   (message-window (conc "File " logfile " not found")))))
	 (xterm      (lambda (x)
		       (if (directory-exists? rundir)
︙︙
297
298
299
300
301
302
303
304




















305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321

322
323
324


325



326
327
328
329
330
331
332

					      (if (not (equal? newval oldval))
						  (begin
						    ;(mutex-lock! mx1)
						    (iup:attribute-set! lbl "TITLE" newval)
						    ;(mutex-unlock! mx1)
						    )))))
			 lbl))
	 (store-button store-label))




















    (cond
     ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
     ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
     (else
      ;;  (test-set-status! db run-id test-name state status itemdat)
      (set! self ; 
	    (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
	     #:title testfullname
	     (iup:vbox ; #:expand "YES"
               ;; The run and test info
	       (iup:hbox  ; #:expand "YES"
		(run-info-panel keydat testdat runname)
		(test-info-panel testdat store-label widgets)
		(test-meta-panel testmeta store-meta))
	       (host-info-panel testdat store-label)
	       ;; The controls
	       (iup:frame #:title "Actions" 

			  (iup:hbox 
			   (iup:button "View Log"    #:action viewlog #:size "120x")
			   (iup:button "Start Xterm" #:action xterm   #:size "120x")


			   (iup:button "Close"       #:action (lambda (x)(exit)) #:size "120x")))



	       (set-fields-panel test-id testdat)
	       (iup:hbox
		(iup:frame 
		 #:title "Test Steps"
		 (let ((stepsdat ;;(iup:label "Test steps ........................................." 
			;;	   #:expand "YES" 
			;;	   #:size "200x150"








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

















>
|
|
|
>
>
|
>
>
>








304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

					      (if (not (equal? newval oldval))
						  (begin
						    ;(mutex-lock! mx1)
						    (iup:attribute-set! lbl "TITLE" newval)
						    ;(mutex-unlock! mx1)
						    )))))
			 lbl))
	 (store-button store-label)
	 (command-text-box (iup:textbox #:expand "YES" #:font "Courier New, -10"))
	 (command-launch-button (iup:button "Execute!" #:action (lambda (x)
								  (let ((cmd (iup:attribute command-text-box "VALUE")))
								    (system (conc cmd "  &"))))))
	 (run-test  (lambda (x)
		      (iup:attribute-set! 
		       command-text-box "VALUE"
		       (conc "megatest -runtests " testname " " keystring " :runname " runname 
			     " -itempatt " (if (equal? item-path "")
					       "%" 
					       item-path)
			     " > run.log" ))))
	 (remove-test (lambda (x)
			(iup:attribute-set!
			 command-text-box "VALUE"
			 (conc "megatest -remove-runs " keystring " :runname " runname " -testpatt " testname " -itempatt "
			       (if (equal? item-path "")
				   "%"
				   item-path)
			       " > clean.log")))))
    (cond
     ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
     ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
     (else
      ;;  (test-set-status! db run-id test-name state status itemdat)
      (set! self ; 
	    (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
	     #:title testfullname
	     (iup:vbox ; #:expand "YES"
               ;; The run and test info
	       (iup:hbox  ; #:expand "YES"
		(run-info-panel keydat testdat runname)
		(test-info-panel testdat store-label widgets)
		(test-meta-panel testmeta store-meta))
	       (host-info-panel testdat store-label)
	       ;; The controls
	       (iup:frame #:title "Actions" 
			  (iup:vbox
			   (iup:hbox 
			    (iup:button "View Log"    #:action viewlog     #:size "120x")
			    (iup:button "Start Xterm" #:action xterm       #:size "120x")
			    (iup:button "Run Test"    #:action run-test    #:size "120x")
			    (iup:button "Clean Test"  #:action remove-test #:size "120x")
			    (iup:button "Close"       #:action (lambda (x)(exit)) #:size "120x"))
			   (apply 
			    iup:hbox
			    (list command-text-box command-launch-button))))
	       (set-fields-panel test-id testdat)
	       (iup:hbox
		(iup:frame 
		 #:title "Test Steps"
		 (let ((stepsdat ;;(iup:label "Test steps ........................................." 
			;;	   #:expand "YES" 
			;;	   #:size "200x150"
︙︙

Modified runs.scm from [55aae7c602] to [10c3a07445].

︙︙
590
591
592
593
594
595
596
597






598
599
600
601
602
603
604
605
606

		   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
		   (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
		   (testdat   #f)
		   (num-running (db:get-count-tests-running db))
		   (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
		   (parent-test (and (not (null? items))(equal? item-path "")))
		   (single-test (and (null? items) (equal? item-path "")))
		   (item-test   (not (equal? item-path ""))))






	      (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	      (if (runs:can-run-more-tests db)
		  (begin
		    (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)








|
>
>
>
>
>
>

|








590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612

		   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
		   (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
		   (testdat   #f)
		   (num-running (db:get-count-tests-running db))
		   (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
		   (parent-test (and (not (null? items))(equal? item-path "")))
		   (single-test (and (null? items) (equal? item-path "")))
		   (item-test   (not (equal? item-path "")))
		   (item-patt   (args:get-arg "-itempatt"))
		   (patt-match  (if item-patt
				    (string-match (glob->regexp
						   (string-translate item-patt "%" "*"))
						  item-path)
				    #t)))
	      (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	      (if (and patt-match (runs:can-run-more-tests db))
		  (begin
		    (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)
︙︙

This page was generated in about 0.113s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00