Megatest

Changes On Branch v1.5411
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch support-for-skip Excluding Merge-Ins

This is equivalent to a diff from 6730a2e1d8 to 98f1cc9c66

2013-04-16
12:47
Merged in support-for-skip check-in: 7635c4e92c user: mrwellan tags: development, v1.5412
2013-04-12
16:09
Added a handle error on creation of a testdat.db in a test directory to hopefully fix the problem where occasionally a test control panel won't run due to the test directory being removed and the sqlite3 db is partially created check-in: 42ed5b696f user: mrwellan tags: development
14:55
Added SKIP handling to rollup of pass/fail counts Closed-Leaf check-in: 98f1cc9c66 user: mrwellan tags: v1.5411, support-for-skip
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
21:38
Fixed bug in auto-regen of top level summary html files check-in: 68511fe827 user: matt tags: development, v1.5409

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 db.scm from [0623ab4501] to [fe4e95ca0a].

︙
1521
1522
1523
1524
1525
1526
1527
1528

1529
1530
1531
1532
1533
1534

1535
1536
1537
1538
1539
1540
1541

1521
1522
1523
1524
1525
1526
1527

1528
1529
1530
1531
1532
1533

1534
1535
1536
1537
1538
1539
1540
1541








-
+





-
+








     run-id test-name)
    res))

;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count
(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  ;; (cdb:flush-queue *runremote*)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK")))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
      (begin
	(sqlite3:execute 
	 db
	 "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
                 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
                 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
             WHERE run_id=? AND testname=? AND item_path='';"
	 run-id test-name run-id test-name run-id test-name)
        ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP?
	(if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
	    (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name)
	    (sqlite3:execute
	     db
︙
1803
1804
1805
1806
1807
1808
1809
1810

1811
1812
1813
1814
1815
1816
1817

1803
1804
1805
1806
1807
1808
1809

1810
1811
1812
1813
1814
1815
1816
1817








-
+









;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;;    if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;;    if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: do not convert to remote as it calls remote under the hood
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK or WAIVED)
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; 
(define (db:get-prereqs-not-met db run-id waitons ref-item-path #!key (mode 'normal))
  (if (or (not waitons)
	  (null? waitons))
      '()
︙
1828
1829
1830
1831
1832
1833
1834
1835

1836
1837
1838
1839
1840
1841
1842

1828
1829
1830
1831
1832
1833
1834

1835
1836
1837
1838
1839
1840
1841
1842








-
+








	     (for-each 
	      (lambda (test)
		;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
		(let* ((state             (db:test-get-state test))
		       (status            (db:test-get-status test))
		       (item-path         (db:test-get-item-path test))
		       (is-completed      (equal? state "COMPLETED"))
		       (is-ok             (member status '("PASS" "WARN" "CHECK" "WAIVED")))
		       (is-ok             (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
		       (same-itempath     (equal? ref-item-path item-path)))
		  (set! ever-seen #t)
		  (cond
		   ;; case 1, non-item (parent test) is 
		   ((and (equal? item-path "") ;; this is the parent test
			 is-completed
			 (or is-ok (eq? mode 'toplevel)))
︙

Modified megatest-version.scm from [0d34c9d034] to [02fa15504b]. 

1
2
3
4
5
6

7

1
2
3
4
5

6
7






-
+


;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.5409)
(define megatest-version 1.5411)

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.128s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00