Megatest

Check-in [2b6812297f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Run tests working
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 2b6812297fd59639a97f0e858471b5fa275e37cb
User & Date: mrwellan on 2013-11-12 09:43:31
Other Links: manifest | tags
Context
2013-11-12
13:48
Dashboard and test control panel working check-in: 2c80291a8d user: mrwellan tags: trunk
09:43
Run tests working check-in: 2b6812297f user: mrwellan tags: trunk
02:11
Blah check-in: 4612e9e264 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [ff2b1171fc] to [a1062addd1].

︙
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36


37
38
39
40
41
42








43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64


65
66
67
68
69
70
71

22
23
24
25
26
27
28

29
30
31

32
33


34
35
36
37
38
39


40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67


68
69
70
71
72
73
74
75
76








-



-
+

-
-
+
+




-
-
+
+
+
+
+
+
+
+




















-
-
+
+








    ((get-keys)                     (db:get-keys db))

    ;; TESTS
    ;; json doesn't do vectors, convert to list
    ((get-test-info-by-id)	       (let ((res (apply db:get-test-info-by-id db params)))
					 (if (vector? res)(vector->list res) res)))
    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id db params))
    ((testmeta-get-record)             (vector->list (apply db:testmeta-get-record db params)))
    ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id db params))
    ((get-count-tests-running)         (db:get-count-tests-running db))
    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup db params))
    ((delete-test-records)             (apply db:delete-test-records params))
    ((delete-test-records)             (apply db:delete-test-records db params))
    ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db))
    ((test-set-status-state)           (apply db:test-set-status-state params))
    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record params))
    ((test-set-status-state)           (apply db:test-set-status-state db params))
    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record db params))
    ((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params)))
    ((db:test-get-logfile-info)        (apply db:test-get-logfile-info db params))
    ((test-get-records-for-index-file  (apply db:test-get-records-for-index-file db params)))
    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status db params))
    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new params))
    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met params))
    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new db params))
    ((get-prereqs-not-met)             (let ((res (apply db:get-prereqs-not-met db params)))
					 (map (lambda (x)
						(if (vector? x)
						    (vector->list x)
						    x))
					      res)))
					 

    ;; RUNS
    ((get-run-info)                 (let ((res (apply db:get-run-info db params)))
				      (list (vector-ref res 0)
					    (vector->list (vector-ref res 1)))))
    ((register-run)                 (apply db:register-run db params))
    ((set-tests-state-status)       (apply db:set-tests-state-status db params))
    ((get-tests-for-run)            (map vector->list (apply db:get-tests-for-run db params)))
    ((get-test-id)                  (apply db:get-test-id-not-cached db params))
    ((get-tests-for-runs-mindata)   (map vector->list (apply db:get-tests-for-runs-mindata db params)))
    ((get-run-name-from-id)         (apply db:get-run-name-from-id db params))
    ((delete-run)                   (apply db:delete-run db params))
    ((get-runs)                     (let* ((res  (apply db:get-runs db params))
					   (hedr (vector-ref res 0))
					   (data (vector-ref res 1)))
				      (list hedr (map vector->list data))))
    ((get-runs-by-patt)             (let* ((res  (apply db:get-runs-by-patt db params))
					   (hedr (vector-ref res 0))
					   (data (vector-ref res 1)))
				      (list hedr (map vector->list data))))
    ((lock/unlock-run)              (apply db:lock/unlock-run params))
    ((update-run-event_time)        (apply db:update-run-event_time params))
    ((lock/unlock-run)              (apply db:lock/unlock-run db params))
    ((update-run-event_time)        (apply db:update-run-event_time db params))

    ;; MISC
    ((login)                        (apply db:login db params))
    ((general-call)                 (let ((stmtname   (car params))
					  (realparams (cdr params)))
				      (db:general-call db stmtname realparams)))
    ((kill-server)
︙
81
82
83
84
85
86
87






88
89


90
91
92
93
94
95
96

86
87
88
89
90
91
92
93
94
95
96
97
98


99
100
101
102
103
104
105
106
107








+
+
+
+
+
+
-
-
+
+








		       port: port)
       (set! *server-run* #f)
       (thread-sleep! 3)
       (if pid 
	   (process-signal pid signal/kill)
	   (thread-start! th1))
       '(#t "exit process started")))

    ;; TESTMETA
    ((testmeta-get-record)       (let ((res (apply db:testmeta-get-record db params)))
				   (if (vector? res)
				       (vector->list res)
				       res)))
    ((testmeta-add-record)       (apply db:testmeta-add-record params))
    ((testmeta-update-field)     (apply db:testmeta-update-field params))
    ((testmeta-add-record)       (apply db:testmeta-add-record db params))
    ((testmeta-update-field)     (apply db:testmeta-update-field db params))
    (else
     (list "ERROR" 0))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
︙

Modified db.scm from [4a152668df] to [5380b387e8].

︙
1050
1051
1052
1053
1054
1055
1056
1057

1058
1059
1060
1061


1062
1063
1064
1065
1066
1067
1068

1050
1051
1052
1053
1054
1055
1056

1057
1058
1059


1060
1061
1062
1063
1064
1065
1066
1067
1068








-
+


-
-
+
+








				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				(case sort-by
				  ((rundir)      " ORDER BY length(rundir) ")
				  ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
				  ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
				  ((event_time)  " ORDER BY event_time ")
				  (else          (if (string? sort-by)
						     (conc " ORDER BY " sort-by)
						     (conc " ORDER BY " sort-by " ")
						     " ")))
				(if sort-order sort-order " ")
				(if limit  (conc " LIMIT " limit)   "")
				(if offset (conc " OFFSET " offset) "")
				(if limit  (conc " LIMIT " limit)   " ")
				(if offset (conc " OFFSET " offset) " ")
				";"
				)))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db
︙
1084
1085
1086
1087
1088
1089
1090
1091
1092





1093
1094
1095
1096
1097
1098

1099
1100
1101
1102
1103
1104
1105
1106

1084
1085
1086
1087
1088
1089
1090


1091
1092
1093
1094
1095
1096
1097
1098
1099
1100

1101

1102
1103
1104
1105
1106
1107
1108








-
-
+
+
+
+
+





-
+
-








	  (vector-ref inrec 5) ;; status
	  -1 "" -1 -1 "" "-" 
	  (vector-ref inrec 3) ;; item-path
	  -1 "-" "-"))


(define (db:get-tests-for-run-state-status db run-id testpatt)
  (let ((res            '())
	(tests-match-qry (tests:match->sqlqry testpatt)))
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)
    (sqlite3:for-each-row
     (lambda (id testname item-path state status)
       ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
       (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
     db 
     (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
     qry
	   (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))
     run-id)
    res))

(define (db:get-testinfo-state-status db test-id)
  (let ((res            #f))
    (sqlite3:for-each-row
     (lambda (run-id testname item-path state status)
︙
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600







1601
1602
1603
1604
1605
1606
1607

1589
1590
1591
1592
1593
1594
1595







1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609








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








;; 	  res))))))
;; 
;; ;; (define (cdb:set-verbosity serverdat val)
;;   (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
;; 
;; (define (cdb:num-clients serverdat)
;;   (cdb:client-call serverdat 'numclients #t *default-numtries*))
;; 
;; (define (db:test-set-status-state db test-id status state msg)
;;   (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;;       (db:general-call db 'set-test-start-time (list test-id)))
;;   (if msg
;;       (db:general-call db 'state-status-msg (list state status msg test-id))
;;       (db:general-call db 'state-status     (list state status test-id))))

(define (db:test-set-status-state db test-id status state msg)
  (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
      (db:general-call db 'set-test-start-time (list test-id)))
  (if msg
      (db:general-call db 'state-status-msg (list state status msg test-id))
      (db:general-call db 'state-status     (list state status test-id))))
;; 
;; (define (cdb:test-rollup-test_data-pass-fail serverdat test-id)
;;   (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))
;; 
;; (define (cdb:tests-register-test serverdat run-id test-name item-path)
;;   (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))
;;
︙

Modified mt.scm from [edaeca98aa] to [c0f326ccbf].

︙
157
158
159
160
161
162
163
164

165
166

167
168
169
170



171
172
173
174
175
176
177

157
158
159
160
161
162
163

164
165

166
167



168
169
170
171
172
173
174
175
176
177








-
+

-
+

-
-
-
+
+
+








;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================

;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment)
  (cond
   ((and newstate newstatus newcomment)
    (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id))
    (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id))
   ((and newstate newstatus)
    (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id))
    (rmt:general-call 'state-status newstate newstatus test-id))
   (else
    (if newstate   (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id))
    (if newstatus  (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id))
    (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id))))
    (if newstate   (rmt:general-call 'set-test-state   newstate test-id))
    (if newstatus  (rmt:general-call 'set-test-status  newstatus test-id))
    (if newcomment (rmt:general-call 'set-test-comment newcomment test-id))))
   (mt:process-triggers test-id newstate newstatus)
   #t)

(define (mt:lazy-get-test-info-by-id test-id)
  (let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
    (if (and tdat 
	     (< (current-seconds)(+ (vector-ref tdat 0) 10)))
︙

Modified rmt.scm from [ac398979bc] to [8065e3007a].

︙
148
149
150
151
152
153
154
155






156
157
158
159
160
161
162

148
149
150
151
152
153
154

155
156
157
158
159
160
161
162
163
164
165
166
167








-
+
+
+
+
+
+








(define (rmt:test-set-log! test-id logf)
  (if (string? logf)(rmt:general-call 'test-set-log logf test-id)))

(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname)))

(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
  (rmt:send-receive 'get-prereqs-not-met (list run-id waitons ref-item-path mode)))
  (let ((res (rmt:send-receive 'get-prereqs-not-met (list run-id waitons ref-item-path mode))))
    (map (lambda (x)
	   (if (list? x)
	       (list->vector x)
	       x))
	 res)))

;; Statistical queries

(define (rmt:get-count-tests-running)
  (rmt:send-receive 'get-count-tests-running '()))

(define (rmt:get-count-tests-running-in-jobgroup jobgroup)
︙
244
245
246
247
248
249
250
251
252




253
254
255

249
250
251
252
253
254
255


256
257
258
259
260
261
262








-
-
+
+
+
+




	(tdb:read-test-data tdb test-id categorypatt)
	'())))

(define (rmt:testmeta-add-record testname)
  (rmt:send-receive 'testmeta-add-record (list testname)))

(define (rmt:testmeta-get-record testname)
  (list->vector
   (rmt:send-receive 'testmeta-get-record (list testname))))
  (let ((res (rmt:send-receive 'testmeta-get-record (list testname))))
    (if (list? res)
	(list->vector res)
	res)))

(define (rmt:testmeta-update-field test-name fld val)
  (rmt:send-receive 'testmeta-update-field (list test-name fld val)))

Modified runs.scm from [9303dbbcd6] to [81f4d40415].

︙
381
382
383
384
385
386
387
388

389
390
391
392
393
394
395

381
382
383
384
385
386
387

388
389
390
391
392
393
394
395








-
+








	  '()
	  reg)))

(define runs:nothing-left-in-queue-count 0)

(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
	 (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met)))
    (debug:print-info 4 "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed
		      "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
		      "\n non-completed:   " (runs:pretty-string non-completed)
︙
586
587
588
589
590
591
592
593

594
595
596
597
598
599
600

586
587
588
589
590
591
592

593
594
595
596
597
598
599
600








-
+








(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry)
  (let* ((run-limits-info         (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources          (car run-limits-info))
	 (num-running             (list-ref run-limits-info 1))
	 (num-running-in-jobgroup (list-ref run-limits-info 2)) 
	 (max-concurrent-jobs     (list-ref run-limits-info 3))
	 (job-group-limit         (list-ref run-limits-info 4))
	 (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
	 (prereqs-not-met         (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
	 (fails                   (runs:calc-fails prereqs-not-met))
	 (non-completed           (runs:calc-not-completed prereqs-not-met))
	 (loop-list               (list hed tal reg reruns)))
    (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" 
		      (string-intersperse 
		       (map (lambda (t)
			      (if (vector? t)
︙

Modified tests.scm from [011440d67f] to [22a4da7218].

︙
239
240
241
242
243
244
245
246

247
248
249
250
251
252
253

239
240
241
242
243
244
245

246
247
248
249
250
251
252
253








-
+








	(begin
	  (rmt:test-set-status-state test-id real-status state (if waived waived comment))
	  (mt:process-triggers test-id state real-status)))
    
    ;; if status is "AUTO" then call rollup (note, this one modifies data in test
    ;; run area, it does remote calls under the hood.
    (if (and test-id state status (equal? status "AUTO")) 
	(db:test-data-rollup #f test-id status work-area: work-area))
	(tdb:test-data-rollup #f test-id status work-area: work-area))

    ;; add metadata (need to do this way to avoid SQL injection issues)

    ;; :first_err
    ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
    ;;   (if val
    ;;       (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
︙
279
280
281
282
283
284
285
286

287
288
289
290
291
292

293
294
295
296
297
298
299

279
280
281
282
283
284
285

286
287
288
289
290
291

292
293
294
295
296
297
298
299








-
+





-
+








			   type     )))
	    ;; This was run remote, don't think that makes sense.
	    (db:csv->test-data #f test-id
				dat))))
      
    ;; need to update the top test record if PASS or FAIL and this is a subtest
    (if (not (equal? item-path ""))
	(mt:roll-up-pass-fail-counts run-id test-name item-path status))
	(rmt:roll-up-pass-fail-counts run-id test-name item-path status))

    (if (or (and (string? comment)
		 (string-match (regexp "\\S+") comment))
	    waived)
	(let ((cmt  (if waived waived comment)))
	  (rmt:general-call 'set-test-comment (list cmt test-id))))))
	  (rmt:general-call 'set-test-comment cmt test-id)))))

(define (tests:test-set-toplog! run-id test-name logf) 
  (rmt:general-call 'tests:test-set-toplog logf run-id test-name))

(define (tests:summarize-items run-id test-id test-name force)
  ;; if not force then only update the record if one of these is true:
  ;;   1. logf is "log/final.log
︙

Modified tests/unittests/server.scm from [55b7665339] to [2057de46b9].

︙
76
77
78
79
80
81
82

83
84
85
86
87
88
89

76
77
78
79
80
81
82
83
84
85
86
87
88
89
90








+








;; MORE RUNS
(test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
			    (header (vector-ref runs 0))
			    (data   (vector-ref runs 1)))
		       (and (list?   header)
			    (list?   data)
			    (vector? (car data)))))


(inmem-test 1 1)

;;======================================================================
;; D B
;;======================================================================
︙

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