Megatest

Check-in [6c2fada4e9]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added support for SKIP.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | support-for-skip
Files: files | file ages | folders
SHA1: 6c2fada4e9966b50a68af7d5122d030f29def2c8
User & Date: mrwellan on 2013-04-12 09:39:43
Other Links: branch diff | manifest | tags
Context
2013-04-12
14:32
Added missing check for legit SKIP status check-in: 233e60104d user: mrwellan tags: v1.5409, support-for-skip
09:39
Added support for SKIP. check-in: 6c2fada4e9 user: mrwellan tags: support-for-skip
2013-04-11
22:39
updated test5 check-in: 6730a2e1d8 user: matt tags: development
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [02a5ef0a9a] to [3109b21887].

︙
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

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








-
+


-
-
+
+
-
-
-
-
+
+
+


-
-
-
+
+
+








(define (common:name->iup-color name)
  (case (string->symbol (string-downcase name))
    ((red)    "223 33 49")
    ((grey)   "192 192 192")
    ((orange) "255 172 13")
    ((purple) "This is unfinished ...")))

(define (common:get-color-for-state-status state status type)
(define (common:get-color-for-state-status state status)
  (case (string->symbol state)
    ((COMPLETED)
     (if (equal? status "PASS")
	 "70 249 73"
     (case (string->symbol status)
       ((PASS)        "70  249 73")
	 (if (or (equal? status "WARN")
		 (equal? status "WAIVED"))
	     "255 172 13"
	     "223 33 49"))) ;; greenish orangeish redish
       ((WARN WAIVED) "255 172 13")
       ((SKIP)        "230 230 0")
       (else "223 33 49")))
    ((LAUNCHED)         "101 123 142")
    ((CHECK)            "255 100 50")
    ((REMOTEHOSTSTART)  "50 130 195")
    ((RUNNING)          "9 131 232")
    ((KILLREQ)          "39 82 206")
    ((REMOTEHOSTSTART)  "50  130 195")
    ((RUNNING)          "9   131 232")
    ((KILLREQ)          "39  82  206")
    ((KILLED)           "234 101 17")
    ((NOT_STARTED)      "240 240 240")
    (else               "192 192 192")))

(define (common:get-color-from-status status)
  (cond
   ((equal? status "PASS")    "green")
︙

Modified dashboard-tests.scm from [0bfb3e05a8] to [9eaeae0a21].

︙
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74

60
61
62
63
64
65
66

67
68
69
70
71
72
73
74








-
+








	    (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" (get-color-for-state-status (db:test-get-state testdat)
					 (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)
︙
186
187
188
189
190
191
192
193

194
195
196
197
198
199
200

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  (get-color-for-state-status state status)))
	 (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)
︙
235
236
237
238
239
240
241
242

243
244
245
246
247
248
249

235
236
237
238
239
240
241

242
243
244
245
246
247
248
249








-
+








	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (open-run-close db:test-set-state-status-by-id #f test-id #f status #f)
								    (db:test-set-status! testdat status)))))
				    btn))
				(list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED"))))
				(list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
︙

Modified dashboard.scm from [7c18e62e8f] to [f8c5b58774].

︙
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

316
317
318
319
320
321
322


















323
324
325
326
327
328
329








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








				(if (> (length parts) 1)(conc "  " (car (string-split (cadr parts) ")"))) newval))))
	      (vector-set! keycol i newval)
	      (iup:attribute-set! lbl "TITLE" munged-val)))
	(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
	(if (< i maxn)
	    (loop (+ i 1)))))))

(define (get-color-for-state-status state status)
  (case (string->symbol state)
    ((COMPLETED)
     (if (equal? status "PASS")
	 "70 249 73"
	 (if (or (equal? status "WARN")
		 (equal? status "WAIVED"))
	     "255 172 13"
	     "223 33 49"))) ;; greenish orangeish redish
    ((LAUNCHED)         "101 123 142")
    ((CHECK)            "255 100 50")
    ((REMOTEHOSTSTART)  "50 130 195")
    ((RUNNING)          "9 131 232")
    ((KILLREQ)          "39 82 206")
    ((KILLED)           "234 101 17")
    ((NOT_STARTED)      "240 240 240")
    (else               "192 192 192")))

(define (update-buttons uidat numruns numtests)
  (if *please-update-buttons*
      (let* ((runs        (if (> (length *allruns*) numruns)
			      (take-right *allruns* numruns)
			      (pad-list *allruns* numruns)))
	     (lftcol      (dboard:uidat-get-lftcol uidat))
	     (tableheader (dboard:uidat-get-header uidat))
︙
412
413
414
415
416
417
418
419

420
421
422
423
424
425
426

394
395
396
397
398
399
400

401
402
403
404
405
406
407
408








-
+








			       (testfullname (test:test-get-fullname test))
			       (teststatus (db:test-get-status   test))
			       (teststate  (db:test-get-state    test))
			       (teststart  (db:test-get-event_time test))
			       (runtime    (db:test-get-run_duration test))
			       (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
			       (button     (vector-ref columndat rown))
			       (color      (get-color-for-state-status teststate teststatus))
			       (color      (common: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))
			      (iup:attribute-set! button "BGCOLOR" color))
			  (if (not (equal? curr-title buttontxt))
			      (iup:attribute-set! button "TITLE"   buttontxt))
			  (vector-set! buttondat 0 run-id)
︙
500
501
502
503
504
505
506
507

508
509
510
511
512
513
514

482
483
484
485
486
487
488

489
490
491
492
493
494
495
496








-
+








	      iup:hbox
	      (map (lambda (status)
		     (iup:toggle status  #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *status-ignore-hash* status #t)
							  (hash-table-delete! *status-ignore-hash* status)))))
	      '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a")))
	      '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
	     (apply 
	      iup:hbox
	      (map (lambda (state)
		     (iup:toggle state   #:action   (lambda (obj val)
						      (mark-for-update)
						      (if (eq? val 1)
							  (hash-table-set! *state-ignore-hash* state #t)
︙

Modified runs.scm from [7187084d9f] to [0af4fb8fbd].

︙
335
336
337
338
339
340
341
342

343
344
345
346
347
348
349

335
336
337
338
339
340
341

342
343
344
345
346
347
348
349








-
+








    (debug:print-info 4 "All done by here")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (equal? (db:test-get-state test) "COMPLETED")
		 (not (member (db:test-get-status test)
			      '("PASS" "WARN" "CHECK" "WAIVED")))))
			      '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))))
	  prereqs-not-met))

(define (runs:calc-not-completed prereqs-not-met)
  (filter
   (lambda (t)
     (or (not (vector? t))
	 (not (equal? "COMPLETED" (db:test-get-state t)))))
︙
689
690
691
692
693
694
695
696

697
698
699
700
701
702
703

689
690
691
692
693
694
695

696
697
698
699
700
701
702
703








-
+








	    (force (set! runflag #t))
	    ;; NOT_STARTED, run no matter what
	    ((member (test:get-state testdat) '("DELETED" "NOT_STARTED"))(set! runflag #t))
	    ;; not -rerun and PASS, WARN or CHECK, do no run
	    ((and (or (not rerun)
		      keepgoing)
		  ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
		  (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))
		  (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP"))
		      (member (test:get-state  testdat) '("COMPLETED")))) 
	     (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
	     (set! runflag #f))
	    ;; -rerun and status is one of the specifed, run it
	    ((and rerun
		  (let* ((rerunlst   (string-split rerun ","))
			 (must-rerun (member (test:get-status testdat) rerunlst)))
︙

Modified tests.scm from [8a34d9b7b7] to [45344ee04b].

︙
507
508
509
510
511
512
513
514

515
516
517
518
519
520
521

507
508
509
510
511
512
513

514
515
516
517
518
519
520
521








-
+








	      (keep-test   #t)
	      (test-id     (cdb:remote-run db:get-test-id #f run-id test-name item-path))
	      (tdat        (cdb:get-test-info-by-id *runremote* test-id)))
	 (if tdat
	     (begin
	       ;; Look at the test state and status
	       (if (or (member (db:test-get-status tdat) 
			       '("PASS" "WARN" "WAIVED" "CHECK"))
			       '("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
		       (member (db:test-get-state tdat)
			       '("INCOMPLETE" "KILLED")))
		   (set! keep-test #f))

	       ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
	       ;; from the runnable list
	       (if keep-test
︙

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