Megatest

Check-in [20cf1d8e3f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Number of bug fixes to tree selectors, run summary etc.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dev | kind-db-access
Files: files | file ages | folders
SHA1: 20cf1d8e3f93a5bd4747dd06c07a94e3404e7582
User & Date: matt on 2013-07-06 14:29:29
Other Links: branch diff | manifest | tags
Context
2013-07-06
15:46
Fixed bigrun to better exercise itemmatch, fixed itemmatch Closed-Leaf check-in: 66f93ef491 user: matt tags: dev, kind-db-access
14:29
Number of bug fixes to tree selectors, run summary etc. check-in: 20cf1d8e3f user: matt tags: dev, kind-db-access
2013-07-05
17:19
Gui clean ups for Run Summary check-in: a8d45ad7dd user: matt tags: dev, kind-db-access
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard-tests.scm from [4baa8f9f2f] to [642a153c9b].

︙︙
21
22
23
24
25
26
27

28
29
30
31
32
33
34


(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))


(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (test-info-panel testdat store-label widgets)
  (iup:frame 








>








21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (test-info-panel testdat store-label widgets)
  (iup:frame
︙︙
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

	    (let ((lbl   (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL")))
	      (hash-table-set! widgets "teststatus"
			       (lambda (testdat)
				 (let ((newstatus (db:test-get-status testdat))
				       (oldstatus (iup:attribute lbl "TITLE")))
				   (if (not (equal? oldstatus newstatus))
				       (begin
					 (iup:attribute-set! lbl "FGCOLOR" (common:get-color-for-state-status (db:test-get-state testdat)
												       (db:test-get-status testdat)))
					 (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
	      lbl)
	    (store-label "testcomment"
			 (iup:label "TestComment                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-comment testdat)))








|
|








61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

	    (let ((lbl   (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL")))
	      (hash-table-set! widgets "teststatus"
			       (lambda (testdat)
				 (let ((newstatus (db:test-get-status testdat))
				       (oldstatus (iup:attribute lbl "TITLE")))
				   (if (not (equal? oldstatus newstatus))
				       (begin
					 (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat)
														   (db:test-get-status testdat))))
					 (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
	      lbl)
	    (store-label "testcomment"
			 (iup:label "TestComment                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-comment testdat)))
︙︙
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200


;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
	 (color  (common:get-color-for-state-status state status)))
    ((vector-ref *state-status* 0) state color)
    ((vector-ref *state-status* 1) status color)))

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel test-id testdat)








|








187
188
189
190
191
192
193
194
195
196
197
198
199
200
201


;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
	 (color  (car (gutils:get-color-for-state-status state status))))
    ((vector-ref *state-status* 0) state color)
    ((vector-ref *state-status* 1) status color)))

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel test-id testdat)
︙︙

Modified dcommon.scm from [577fc9d8e3] to [9ceb7ccb63].

︙︙
336
337
338
339
340
341
342
343
344


345
346
347
348
349
350
351
352
353
354
355
356


(define (dcommon:run-stats)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (mt:get-run-stats))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(max-row      (apply max (map cadr (car indices))))
				(max-col      (apply max (map cadr (cadr indices))))


				(max-visible  (max (- *num-tests* 15) 3))
				(numrows      1)
				(numcols      1)
				(row-indices  (car indices))
				(col-indices  (cadr indices)))
			   (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			   (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			   (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col)
			   (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))

			   ;; Row labels








|
|
>
>


|
<
<








336
337
338
339
340
341
342
343
344
345
346
347
348
349


350
351
352
353
354
355
356


(define (dcommon:run-stats)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (mt:get-run-stats))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
				(numrows      1)
				(numcols      1))


			   (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			   (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			   (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col)
			   (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))

			   ;; Row labels
︙︙

Modified tests/Makefile from [14525358f8] to [bb3b09cc9d].

︙︙
111
112
113
114
115
116
117











118
119
120
121
122
123
124

	@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
	cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9d :
	@echo Run an itemized test with no items
	cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)












minsetup : 
	cd ..;make && make install
	mkdir -p mintest/runs mintest/links
	cd mintest;megatest -stop-server 0
	cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & 
	sleep 3
	cd mintest;dashboard -rows 20 &








>
>
>
>
>
>
>
>
>
>
>








111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

	@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
	cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test9d :
	@echo Run an itemized test with no items
	cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)

test10 :
	@echo Run a bunch of different targets simultaneously
	(cd fullrun;$(MEGATEST) -server - ;sleep 2)&
	for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \
	   (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done
	for sys in ubuntu suse redhat debian;do \
	  for fs in afs nfs zfs; do \
	     for dpath in none tmp; do \
	        (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\
	     done;done;done

minsetup : 
	cd ..;make && make install
	mkdir -p mintest/runs mintest/links
	cd mintest;megatest -stop-server 0
	cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & 
	sleep 3
	cd mintest;dashboard -rows 20 &
︙︙

Modified tree.scm from [c1543d268a] to [e7e38b65a4].

︙︙
96
97
98
99
100
101
102
103
104
105
106
107
108

109
110
111
112
113
114
115
116

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added
		#t
		(loop (car tal)(cdr tal)(+ depth 1) newpath))))))))

(define (tree:node->path obj nodenum)
  ;; (print "\ncurrnode  nodenum  depth  node-depth  node-title   path")
  (let loop ((currnode 0)
	     (depth    0)
	     (path     '()))
    (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode)))
	  (node-title (iup:attribute obj (conc "TITLE" currnode))))

      ;; (display (conc "\n   "currnode "        " nodenum "       " depth "         " node-depth "          " node-title "         " path))
      (if (> currnode nodenum)
	  path
	  (if (not node-depth) ;; #f if we are out of nodes
	      '()
	      (let ((ndepth (string->number node-depth)))
		(if (eq? ndepth depth)
		    ;; This next is the match condition depth == node-depth

		    (if (eq? currnode nodenum)
			(begin
			  ;; (display " <X>")
			  (append path (list node-title)))
			(loop (+ currnode 1)
			      (+ depth 1)
			      (append path (list node-title))))
		    ;; didn't match, reset to base path and keep looking
		    ;; due to more iup odditys we don't reset to base
		    (begin 
		      ;; (display " <L>")
		      (loop (+ 1 currnode)
			    2
			    (append (take path ndepth)(list node-title)))))))))))









<

<

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

96
97
98
99
100
101
102

103

104
105
106
107
108
109
110





111
112


113
114
115






116



		  ;; reset to top
		  (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	    (if (null? tal) ;; if null here then this path has already been added
		#t
		(loop (car tal)(cdr tal)(+ depth 1) newpath))))))))

(define (tree:node->path obj nodenum)

  (let loop ((currnode 0)

	     (path     '()))
    (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode))))
	   (node-title (iup:attribute obj (conc "TITLE" currnode)))
	   (trimpath   (if (and (not (null? path))
				(> (length path) node-depth))
			   (take path node-depth)
			   path))





	   (newpath    (append trimpath (list node-title))))
      (if (>= currnode nodenum)


	  newpath
	  (loop (+ currnode 1)
		newpath)))))

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