Megatest

Check-in [c350a6b24f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added img to buttons for GTK3 change
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-real-button-img
Files: files | file ages | folders
SHA1: c350a6b24fb58bc52cc55c5184e02d7c3db926bc
User & Date: matt on 2021-03-06 21:28:44
Other Links: branch diff | manifest | tags
Context
2021-03-06
21:49
Increased the image size Leaf check-in: 7d7f638673 user: matt tags: v1.65-real-button-img
21:28
Added img to buttons for GTK3 change check-in: c350a6b24f user: matt tags: v1.65-real-button-img
2021-02-25
15:46
Missing dep. check-in: 80a01976f7 user: matt tags: v1.65-real
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard.scm from [065c30d7e0] to [030af5c373].

︙
188
189
190
191
192
193
194





































195
196
197
198
199
200
201

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








   tabdats:              (make-hash-table)
   please-update:        #t
   update-mutex:         (make-mutex)
   updaters:             (make-hash-table)
   updating:             #f
   hide-not-hide-tabs:   #f
   ))

;;======================================================================
;; buttons color using image
;;======================================================================

(define *images* (make-hash-table))

(define (make-image images name color)
  (if (hash-table-exists? images name)
      name
      (let* ((img-bits1 (u8vector->blob (u8vector
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 1 1 1 1 1 1 1 1 
					 )))
	     ;;                       w h
	     (img1 (iup:image/palette 8 16 img-bits1)))
	(iup:handle-name-set! img1 name)
	;; (iup:attribute-set! img1 "0" "0 0 0")
	(iup:attribute-set! img1 "1" color) ;; "BGCOLOR")
	;; (iup:attribute-set! img1 "2" "255 0 0")
	(hash-table-set! images name img1)
	name)))


;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
  (let* ((tnum (or tab-num
		   (dboard:commondat-curr-tab-num commondat)
		   0)) ;; tab-num value is curr-tab-num value in passed commondat
︙
1070
1071
1072
1073
1074
1075
1076
1077



1078
1079
1080
1081
1082
1083
1084

1107
1108
1109
1110
1111
1112
1113

1114
1115
1116
1117
1118
1119
1120
1121
1122
1123








-
+
+
+








  (let* ((runs        (if (> (length (dboard:tabdat-allruns tabdat)) numruns)
			  (take-right (dboard:tabdat-allruns tabdat) numruns)
			  (pad-list (dboard:tabdat-allruns tabdat) numruns)))
	 (lftcol      (dboard:uidat-get-lftcol uidat))
	 (tableheader (dboard:uidat-get-header uidat))
	 (table       (dboard:uidat-get-runsvec uidat))
	 (coln        0)
	 (all-test-names (make-hash-table)))
	 (all-test-names (make-hash-table))
	 (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work
	 )
    ;; create a concise list of test names
    ;;
    (for-each
     (lambda (rundat)
       (if rundat
	   (let* ((testdats  (dboard:rundat-tests rundat))
		  (testnames (map test:test-get-fullname (hash-table-values testdats))))
︙
1169
1170
1171
1172
1173
1174
1175

1176
1177
1178





1179
1180
1181
1182
1183
1184
1185

1208
1209
1210
1211
1212
1213
1214
1215



1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227








+
-
-
-
+
+
+
+
+








					  (else
					   teststate)))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))
			  (if use-bgcolor
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
			      (iup:attribute-set! button "BGCOLOR" color)
			      (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color))))
		      (if (and (not use-bgcolor) ;; bgcolor does not work with text
			       (not (equal? curr-title buttontxt)))
			  (iup:attribute-set! button "TITLE" buttontxt))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)
		      (vector-set! buttondat 3 testdat)
		      (vector-set! buttondat 4 run-key)))
		(set! rown (+ rown 1))))
	    (dboard:tabdat-all-test-names tabdat)))
︙
2755
2756
2757
2758
2759
2760
2761
2762


2763
2764
2765
2766
2767
2768
2769

2797
2798
2799
2800
2801
2802
2803

2804
2805
2806
2807
2808
2809
2810
2811
2812








-
+
+








	 (lftlst          '())
	 (hdrlst          '())
	 (bdylst          '())
	 (result          '())
	 (i               0)
	 (btn-height      (dboard:tabdat-runs-btn-height runs-dat))
	 (btn-fontsz      (dboard:tabdat-runs-btn-fontsz runs-dat))
	 (cell-width      (dboard:tabdat-runs-cell-width runs-dat)))
	 (cell-width      (dboard:tabdat-runs-cell-width runs-dat))
	 (use-bgcolor     (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")))
    ;; controls (along bottom)
    ;; (set! controls (dboard:make-controls commondat runs-dat))
    
    ;; create the left most column for the run key names and the test names 
    (set! lftlst
	  (list (iup:hbox
		 (iup:label) ;; (iup:valuator)
︙
2864
2865
2866
2867
2868
2869
2870
2871

2872
2873
2874
2875
2876
2877
2878

2907
2908
2909
2910
2911
2912
2913

2914
2915
2916
2917
2918
2919
2920
2921








-
+








       ((>= testnum ntests) 
	(vector-set! runsvec runnum testvec)
	(set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
	(loop (+ runnum 1) 0 (make-vector ntests) '()))
       (else
	(let* ((button-key (mkstr runnum testnum))
	       (butn       (iup:button
			    "" ;; button-key 
			    (if use-bgcolor #f "   ") ;; button-key 
			    #:size (conc cell-width btn-height )
			    #:expand "HORIZONTAL"
			    #:fontsize btn-fontsz
			    #:button-cb
			    (lambda (obj a pressed x y btn . rem)
			      ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
			      (if  (substring-index "3" btn)
︙
2906
2907
2908
2909
2910
2911
2912

2913
2914
2915
2916
2917
2918
2919

2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963








+








					 ))
				   (if (eq? pressed 0)
				       (let* ((toolpath (car (argv)))
					      (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
					      (test-id  (db:test-get-id (vector-ref buttndat 3)))
					      (run-id   (db:test-get-run_id (vector-ref buttndat 3))))
                                         (dboard:launch-testpanel run-id test-id))))))))
	  (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR")
	  (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
︙

Modified gutils.scm from [94030f1a6e] to [455c3c7ee1]. 

1

2
3
4
5
6
7
8


1
2
3
4
5
6
7
8

-
+








;;======================================================================
';;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
︙
81
82
83
84
85
86
87
88




89

81
82
83
84
85
86
87

88
89
90
91
92








-
+
+
+
+


     (case (string->symbol status)
       ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT)  (list "200 130 13" status)) ;; orange requested for these
       (else  (list "60  235 63" status))))
    ((DIRTY-BETTER)     (list "160  255 153" status))
    ((DIRTY-WORSE)      (list "165 42  42" status))
    ((BOTH-BAD)         (list "180 33 49" status))

    (else               (list "192 192 192"  state))))
    (else               (list
			 ;; "192 192 192"
			 "222 222 221"
			 state))))

Modified widgets.scm from [dcc875399e] to [3a32b6256a].

︙
12
13
14
15
16
17
18
19



20
21
22
23
24
25
26

12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28








-
+
+
+








;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(require-library srfi-4 iup)
(import srfi-4 iup iup-pplot iup-glcanvas) ;; iup-web
(import srfi-4 iup
	;; iup-pplot
	iup-glcanvas) ;; iup-web

(define (popup dlg . args)
  (apply show dlg #:modal? 'yes args)
  (destroy! dlg))

(define (properties ih)
  (popup (element-properties-dialog ih))
︙
130
131
132
133
134
135
136
137

138
139
140
141
142
143
144

132
133
134
135
136
137
138

139
140
141
142
143
144
145
146








-
+








        (button "dial"
                action: (lambda (self) (properties (dial ""))))
        (button "matrix"
                action: (lambda (self) (properties (matrix))))
        (fill)
        margin: '0x0)
      (hbox
        (button "pplot"
        #;(button "pplot"
                action: (lambda (self) (properties (pplot))))
        (button "glcanvas"
                action: (lambda (self) (properties (glcanvas))))
        ;; (button "web-browser"
        ;;         action: (lambda (self) (properties (web-browser))))
        (fill)
        margin: '0x0)
︙

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