Megatest

Check-in [a72100abbd]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Changed logic on hiding tests matching combo of state and status
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a72100abbddd4b49f1406dd7c3ca4f5d942e68e2
User & Date: matt on 2011-10-11 22:31:02
Other Links: manifest | tags
Context
2011-10-11
22:56
Reduced cpu usage of dashboard substantially and off-by-one error check-in: 9797f62e06 user: matt tags: trunk
22:31
Changed logic on hiding tests matching combo of state and status check-in: a72100abbd user: matt tags: trunk
21:24
Fixed install of nbfake to work right check-in: fe03d0b115 user: mrwellan tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard.scm from [0ed20ba503] to [61c8921b01].

︙
179
180
181
182
183
184
185
186


187
188
189
190
191
192
193

179
180
181
182
183
184
185

186
187
188
189
190
191
192
193
194








-
+
+








  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt itemnamepatt keypatts)
  (let* ((allruns     (db:get-runs *db* runnamepatt (+ numruns (/ numruns 2)) *start-run-offset* keypatts))
  (let* ((allruns     (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
		      *start-run-offset* keypatts))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (states      (hash-table-keys *state-ignore-hash*))
	 (statuses    (hash-table-keys *status-ignore-hash*)))
    ;; Instead of this mechanism lets try setting number of runs based on "result" below
︙
501
502
503
504
505
506
507
508

509
510
511
512
513
514
515

502
503
504
505
506
507
508

509
510
511
512
513
514
515
516








-
+








							 (hash-table-set! *state-ignore-hash* "NOT_STARTED" #t)
							 (hash-table-delete! *state-ignore-hash* "NOT_STARTED"))))
	      (iup:toggle "KILLED"   #:action   (lambda (obj val)
						  (if (eq? val 1)
						      (hash-table-set! *state-ignore-hash* "KILLED" #t)
						      (hash-table-delete! *state-ignore-hash* "KILLED")))))))
	   (iup:valuator #:valuechanged_cb (lambda (obj)
					     (let ((val (inexact->exact (round (+ 0.5 (string->number (iup:attribute obj "VALUE"))))))
					     (let ((val (inexact->exact (round (+ 0.0 (string->number (iup:attribute obj "VALUE"))))))
						   (maxruns  *tot-run-count*)) ;;; (+ *num-runs* (length *allruns*))))
					       (set! *start-run-offset* val)
					       (debug:print 3 "maxruns: " maxruns ", val: " val)
					       (iup:attribute-set! obj "MAX" maxruns)))
			 #:expand "YES"
			 #:max (+ ;; *num-runs*
				(length *allruns*)))
︙

Modified db.scm from [931afe1758] to [fda4c90157].

︙
353
354
355
356
357
358
359

360
361
362
363

364
365


366
367
368
369
370
371
372


373
374
375
376
377
378
379

353
354
355
356
357
358
359
360
361
362


363


364
365
366
367
368
369
370


371
372
373
374
375
376
377
378
379








+


-
-
+
-
-
+
+





-
-
+
+









;;======================================================================
;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
(define (db-get-tests-for-run db run-id testpatt itempatt states statuses)
  (let ((res '())
	(states-str   (if (and states (not (null? states)))
			  (conc " AND state NOT IN ('" (string-intersperse states   "','") "')") ""))
	(states-str    (conc "('" (string-intersperse states   "','") "')"))
	(statuses-str (if (and statuses (not (null? statuses)))
			  (conc " AND status NOT IN ('" (string-intersperse statuses "','") "')") "")))
	(statuses-str  (conc "('" (string-intersperse statuses "','") "')"))
	)
    (sqlite3:for-each-row 
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment first-err first-warn)
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment first-err first-warn) res)))
     db 
     (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,first_err,first_warn "
	   " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? "
	   states-str statuses-str
	   " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " 
	   " AND NOT (state in " states-str " AND status IN " statuses-str ") "
	   " ORDER BY id DESC;")
     run-id
     (if testpatt testpatt "%")
     (if itempatt itempatt "%"))
    res))

;; this one is a bit broken BUG FIXME
︙
672
673
674
675
676
677
678
679

680
681
682
683
684
685
686

672
673
674
675
676
677
678

679
680
681
682
683
684
685
686








-
+








;;
;; Return a list of prereqs that were NOT met
;;  Tests (and all items) in waiton list must be "COMPLETED" and "PASS"
(define (db-get-prereqs-not-met db run-id waiton)
  (if (null? waiton)
      '()
      (let* ((unmet-pre-reqs '())
	     (tests           (db-get-tests-for-run db run-id #f #f))
	     (tests           (db-get-tests-for-run db run-id #f #f '() '()))
	     (result         '()))
	(for-each (lambda (waitontest-name)
		    (let ((ever-seen #f))
		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (begin
					(set! ever-seen #t)
︙

Modified megatest.scm from [8519508a08] to [b0196f050b]. 

1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20













-
+








;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (include "common.scm")
;; (include "megatest-version.scm")

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

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
︙
251
252
253
254
255
256
257
258

259
260
261
262
263
264
265

251
252
253
254
255
256
257

258
259
260
261
262
263
264
265








-
+








	 (debug:print 2 "Run: "
		(string-intersperse (map (lambda (x)
					   (db:get-value-by-header run header x))
					 keynames) "/")
		"/"
		(db:get-value-by-header run header "runname"))
	 (let ((run-id (db:get-value-by-header run header "id")))
	   (let ((tests (db-get-tests-for-run db run-id testpatt itempatt #f #f)))
	   (let ((tests (db-get-tests-for-run db run-id testpatt itempatt '() '())))
	     ;; Each test
	     (for-each 
	      (lambda (test)
		(format #t
			"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
			(conc (db:test-get-testname test)
			      (if (equal? (db:test-get-item-path test) "")
︙

Modified runs.scm from [e4c70b394e] to [96f6e3d21b].

︙
126
127
128
129
130
131
132
133

134
135
136
137
138
139
140

126
127
128
129
130
131
132

133
134
135
136
137
138
139
140








-
+








		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db-get-tests-for-run db hed test-name item-path #f #f)))
		(let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))
︙
164
165
166
167
168
169
170
171

172
173
174
175
176
177
178

164
165
166
167
168
169
170

171
172
173
174
175
176
177
178








-
+








	  ;; collect all matching tests for the runs then
	  ;; extract the most recent test and return that.
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
		       ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db-get-tests-for-run db hed test-name item-path #f #f)))
		(let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name 
			       ", item-path " item-path " results: " (intersperse results "\n"))
		  ;; Keep only the youngest of any test/item combination
		  (for-each 
		   (lambda (testdat)
		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))
︙
748
749
750
751
752
753
754
755

756
757
758
759
760
761
762

748
749
750
751
752
753
754

755
756
757
758
759
760
761
762








-
+








    (debug:print 1 "Header: " header)
    (for-each
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
	     (dirs-to-remove (make-hash-table)))
	 (let* ((run-id (db:get-value-by-header run header "id") )
		(tests  (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt #f #f))
		(tests  (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
		(lasttpath "/does/not/exist/I/hope"))

	   (if (not (null? tests))
	       (begin
		 (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
		 (for-each
		  (lambda (test)
︙
799
800
801
802
803
804
805
806

807
808
809
810
811
812
813

799
800
801
802
803
804
805

806
807
808
809
810
811
812
813








-
+








			  (debug:print 2 "Removing directory with zero db references: " dir-to-remove)
			  (system (conc "rm -rf " dir-to-remove))
			  (hash-table-delete! dirs-to-remove dir-to-remove))
			(debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
	    (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))

	   ;; remove the run if zero tests remain
	   (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id") #f #f #f #f)))
	   (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
	     (if (null? remtests) ;; no more tests remaining
		 (let* ((dparts  (string-split lasttpath "/"))
			(runpath (conc "/" (string-intersperse 
					    (take dparts (- (length dparts) 1))
					    "/"))))
		   (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
		   (db:delete-run db run-id)
︙
885
886
887
888
889
890
891
892

893
894
895
896
897
898
899

885
886
887
888
889
890
891

892
893
894
895
896
897
898
899








-
+








	 (runs:update-test_meta db test-name test-conf)))
     test-names)))
	 
;; This could probably be refactored into one complex query ...
(define (runs:rollup-run db keys)
  (let* ((new-run-id      (register-run db keys))
	 (prev-tests      (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (db-get-tests-for-run db new-run-id "%" "%" #f #f))
	 (curr-tests      (db-get-tests-for-run db new-run-id "%" "%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    ;; index the already saved tests by testname and itempath in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
︙
912
913
914
915
916
917
918
919

920
921
922
923
924
925
926

912
913
914
915
916
917
918

919
920
921
922
923
924
925
926








-
+








	      (new-test-record #f))
	 ;; replace these with insert ... select
	 (apply sqlite3:execute 
		db 
		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,first_err,first_warn) "
		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
		new-run-id (cddr (vector->list testdat)))
	 (set! new-testdat (car (db-get-tests-for-run db new-run-id testname item-path #f #f)))
	 (set! new-testdat (car (db-get-tests-for-run db new-run-id testname item-path '() '())))
	 (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table?
	 ;; Now duplicate the test steps
	 (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
	 (sqlite3:execute 
	  db 
	  (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) "
		"SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;")
︙

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