Megatest

Check-in [7fcc4d2c40]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Better handling of comment editing on waived in the test control panel
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.55
Files: files | file ages | folders
SHA1: 7fcc4d2c40d37f9b3da14589c54d89a790ff9a3b
User & Date: matt on 2013-12-11 22:37:35
Other Links: branch diff | manifest | tags
Context
2014-01-06
15:36
tweak to mtgetfile but it is not completed ... check-in: 6014aa8df2 user: mrwellan tags: v1.55
2013-12-11
22:37
Better handling of comment editing on waived in the test control panel check-in: 7fcc4d2c40 user: matt tags: v1.55
2013-12-10
17:01
Must quote strings for the environment if they contain ; check-in: aa1906bbeb user: mrwellan tags: v1.55
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard-tests.scm from [0ec8aba244] to [476569a731].

︙
71
72
73
74
75
76
77
78








79
80
81
82
83
84
85

71
72
73
74
75
76
77

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92








-
+
+
+
+
+
+
+
+








														   (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)))
			   (let ((newcomment (db:test-get-comment testdat)))
			     (if *dashboard-comment-share-slot*
				 (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE")
						  newcomment))
				     (iup:attribute-set! *dashboard-comment-slot*
							 "VALUE"
							 newcomment)))
			     newcomment)))
	    (store-label "testid"
			 (iup:label "TestId                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-id testdat)))
	    (store-label "testdate" 
			 (iup:label "TestDate                           "
︙
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

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
239
240
241
242
243
244
245
246
247
248
249
250








+







-
+
+




-
-
-
-
-
-
+
+
+
+
+
+
+
+
+








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

(define *dashboard-test-db* #t)
(define *dashboard-comment-share-slot* #f)

;;======================================================================
;; Set fields 
;;======================================================================
(define (set-fields-panel test-id testdat #!key (db #f))
  (let ((newcomment #f)
	(newstatus  #f)
	(newstate   #f))
	(newstate   #f)
	(wtxtbox    #f))
    (iup:frame
     #:title "Set fields"
     (iup:vbox
      (iup:hbox (iup:label "Comment:")
		(iup:textbox #:action (lambda (val a b)
					;; IDEA: Just set a variable with the proc to call?
					(open-run-close db:test-set-state-status-by-id db test-id #f #f b)
					(set! newcomment b))
			     #:value (db:test-get-comment testdat)
			     #:expand "HORIZONTAL"))
		(let ((txtbox (iup:textbox #:action (lambda (val a b)
						      ;; IDEA: Just set a variable with the proc to call?
						      (open-run-close db:test-set-state-status-by-id db test-id #f #f b)
						      (set! newcomment b))
					   #:value (db:test-get-comment testdat)
					   #:expand "HORIZONTAL")))
		  (set! wtxtbox txtbox)
		  txtbox))
		  
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (open-run-close db:test-set-state-status-by-id db test-id state #f #f)
︙
253
254
255
256
257
258
259
260
261










262
263
264
265
266
267
268

265
266
267
268
269
270
271


272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288








-
-
+
+
+
+
+
+
+
+
+
+








	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (let ((t (iup:attribute x "TITLE")))
								      (if (equal? t "WAIVED")
									  (iup:show (dashboard-tests:waiver testdat (lambda (c)
														      (set! newcomment c))))
									  (iup:show (dashboard-tests:waiver testdat 
													    (if wtxtbox (iup:attribute wtxtbox "VALUE") #f)
													    (lambda (c)
													      (set! newcomment c)
													      (if wtxtbox 
														  (begin
														    (iup:attribute-set! wtxtbox "VALUE" c)
														    (if (not *dashboard-comment-share-slot*)
															(set! *dashboard-comment-share-slot* wtxtbox)))
														  ))))
									  (begin
									    (open-run-close db:test-set-state-status-by-id db test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				*common:std-statuses*))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
︙
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

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








-
+









-
+








					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))

(define (dashboard-tests:waiver testdat cmtcmd)
(define (dashboard-tests:waiver testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
	 (wregx (if (string? wpatt)(regexp wpatt) #f))
	 (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
	 (comnt (iup:textbox #:action (lambda (val a b)
					(if wpatt
					    (if (string-match wregx b)
						(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
						(iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt))
						)))
			     #:value (db:test-get-comment testdat)
			     #:value (if ovrdval ovrdval (db:test-get-comment testdat))
			     #:expand "HORIZONTAL"))
	 (dlog  #f))
    (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
		#:title "SET WAIVER"
		(iup:vbox ; #:expand "YES"
		 (iup:label (conc "Enter justification for waiving test "
				  (db:test-get-testname testdat)
︙

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