Megatest

Check-in [bcaec59285]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Made mt:process-triggers run exclusively on the server side
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.63-stackdumpfix
Files: files | file ages | folders
SHA1: bcaec592852774ae2fca6a61ca6bb0d834e85ca0
User & Date: matt on 2017-01-06 22:37:18
Other Links: branch diff | manifest | tags
Context
2017-01-07
17:07
Changed some calls using status-state order to state-status to be consistent and easier to read. check-in: bf1dd4b5fc user: matt tags: v1.63-stackdumpfix
2017-01-06
22:37
Made mt:process-triggers run exclusively on the server side check-in: bcaec59285 user: matt tags: v1.63-stackdumpfix
21:54
utils/plot-code.scm check-in: 064872f8bc user: matt tags: v1.63-stackdumpfix
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified db.scm from [b31dceb2af] to [aa5dac4609].

︙
1959
1960
1961
1962
1963
1964
1965
1966

1967
1968
1969
1970
1971
1972
1973

1959
1960
1961
1962
1963
1964
1965

1966
1967
1968
1969
1970
1971
1972
1973








-
+








	"SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;"
	run-id))))

;; Update run_stats for given run_id
;; input data is a list (state status count)
;;
(define (db:update-run-stats dbstruct run-id stats)
  (mutex-lock! *db-transaction-mutex*)
  ;; (mutex-lock! *db-transaction-mutex*)
  (db:with-db
   dbstruct
   #f
   #f

   (lambda (db)
     ;; remove previous data
︙
1981
1982
1983
1984
1985
1986
1987
1988

1989
1990
1991
1992
1993
1994
1995

1981
1982
1983
1984
1985
1986
1987

1988
1989
1990
1991
1992
1993
1994
1995








-
+








		(for-each
		 (lambda (dat)
		   (sqlite3:execute stmt1 run-id (car dat)(cadr dat))
		   (apply sqlite3:execute stmt2 run-id dat))
		 stats)))))
       (sqlite3:finalize! stmt1)
       (sqlite3:finalize! stmt2)
       (mutex-unlock! *db-transaction-mutex*)
       ;; (mutex-unlock! *db-transaction-mutex*)
       res))))

(define (db:get-main-run-stats dbstruct run-id)
  (db:with-db
   dbstruct
   #f ;; this data comes from main
   #f
︙
2485
2486
2487
2488
2489
2490
2491
2492


2493
2494
2495
2496
2497
2498
2499

2485
2486
2487
2488
2489
2490
2491

2492
2493
2494
2495
2496
2497
2498
2499
2500








-
+
+








		(db:with-db
		 dbstruct
		 run-id
		 #t
		 (lambda (db)
		   (let ((test-id (db:get-test-id dbstruct run-id testname "")))
		     (sqlite3:execute db qry newstate newstatus run-id testname)
		     (if test-id (mt:process-triggers run-id test-id newstate newstatus)))
		     (if test-id (mt:process-triggers dbstruct run-id test-id newstate newstatus))
		     )
		   ))))
	    testnames))

;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment)
︙
2509
2510
2511
2512
2513
2514
2515
2516

2517
2518
2519
2520
2521
2522
2523

2510
2511
2512
2513
2514
2515
2516

2517
2518
2519
2520
2521
2522
2523
2524








-
+








      ((and newstate newstatus)
       (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
      (else
       (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
       (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
       (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
				       test-id))))
     (mt:process-triggers run-id test-id newstate newstatus))))
     (mt:process-triggers dbstruct run-id test-id newstate newstatus))))

;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
︙
3153
3154
3155
3156
3157
3158
3159
3160

3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180

3181
3182
3183
3184
3185
3186
3187

3154
3155
3156
3157
3158
3159
3160

3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180

3181
3182
3183
3184
3185
3186
3187
3188








-
+



















-
+








    ;; (if msg
    ;; 	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
    ;; 	(db:general-call dbdat 'state-status     (list state status test-id)))
    (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
    ;; process the test_data table
    (if (and test-id state status (equal? status "AUTO")) 
	(db:test-data-rollup dbstruct run-id test-id status))
    (mt:process-triggers run-id test-id state status)))
    (mt:process-triggers dbstruct run-id test-id state status)))

;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test
  (let* ((db           (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct)))
	 (testdat      (if (number? test-name)
			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
			   (db:get-test-info       dbstruct run-id test-name item-path)))
	 (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))
	 (item-path    (db:test-get-item-path testdat))
         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
         (tl-test-id   (db:test-get-id tl-testdat)))
    (mutex-lock! *db-transaction-mutex*)
    ;; (mutex-lock! *db-transaction-mutex*)
    (let ((tr-res
           (sqlite3:with-transaction
            db
            (lambda ()
              (db:test-set-state-status-by-id dbstruct run-id test-id state status comment)
              (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
                  (let* ((state-status-counts  (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
︙
3207
3208
3209
3210
3211
3212
3213
3214


3215
3216
3217
3218
3219
3220
3221

3208
3209
3210
3211
3212
3213
3214

3215
3216
3217
3218
3219
3220
3221
3222
3223








-
+
+








                                                    "COMPLETED"
                                                    (car all-curr-states))))
                         (newstatus         (if (> bad-not-started 0)
                                                "CHECK"
                                                (car all-curr-statuses))))
                    ;; (print "Setting toplevel to: " newstate "/" newstatus)
                    (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f))))))
          (mutex-unlock! *db-transaction-mutex*))
          ;;(mutex-unlock! *db-transaction-mutex*)
	  )
      tr-res)))

(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items)

;; call with state = #f to roll up with out accounting for state/status of this item
;;
;;    (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status)
︙

Modified mt.scm from [1d20117cfc] to [8b3b9cbacc].

︙
126
127
128
129
130
131
132
133
134


135
136
137
138
139
140
141

126
127
128
129
130
131
132


133
134
135
136
137
138
139
140
141








-
-
+
+








			    res)
			  (cons testn res)))))))))

;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers run-id test-id newstate newstatus)
  (let* ((test-dat      (rmt:get-test-info-by-id run-id test-id)))
(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
  (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
    (if test-dat
	(let* ((test-rundir   ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb*
		(db:test-get-rundir test-dat)) ;; ) ;; )
	       (test-name     (db:test-get-testname test-dat))
	       (tconfig       #f)
	       (state         (if newstate  newstate  (db:test-get-state  test-dat)))
	       (status        (if newstatus newstatus (db:test-get-status test-dat))))
︙
185
186
187
188
189
190
191
192

193
194
195
196
197
198

199
200
201
202
203
204
205

185
186
187
188
189
190
191

192
193
194
195
196
197

198
199
200
201
202
203
204
205








-
+





-
+








	;; ((and newstate newstatus)
	;;  (rmt:general-call 'state-status run-id newstate newstatus test-id))
	;; (else
	;;  (if newstate   (rmt:general-call 'set-test-state   run-id newstate   test-id))
	;;  (if newstatus  (rmt:general-call 'set-test-status  run-id newstatus  test-id))
	;;  (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
	(rmt:roll-up-pass-fail-counts run-id test-id #f newstate newstatus newcomment)
	(mt:process-triggers run-id test-id newstate newstatus)
	;; (mt:process-triggers run-id test-id newstate newstatus)
	#t)))

(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (rmt:get-test-id run-id test-name item-path)))
    (rmt:roll-up-pass-fail-counts run-id test-name item-path new-state new-status new-comment)
    (mt:process-triggers run-id test-id new-state new-status)
    ;; (mt:process-triggers run-id test-id new-state new-status)
    #t))
	;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))

(define (mt:lazy-read-test-config test-name)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
︙

Modified tests.scm from [99a08e573f] to [585eeaa784].

︙
350
351
352
353
354
355
356
357

358
359

360
361
362
363
364
365
366

350
351
352
353
354
355
356

357
358

359
360
361
362
363
364
365
366








-
+

-
+








					#t
					(loop (car tal)(cdr tal)))
				    #f))))))
	    (pop-directory)
	    result)))))

(define (tests:test-force-state-status! run-id test-id state status)
  (rmt:test-set-status-state run-id test-id status state #f)
  (rmt:test-set-status-state run-id test-id status state #f))
  ;; (rmt:roll-up-pass-fail-counts run-id test-name item
  (mt:process-triggers run-id test-id state status))
  ;; (mt:process-triggers run-id test-id state status))

;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f))
  (let* ((real-status status)
	 (otherdat    (if dat dat (make-hash-table)))
	 (testdat     (rmt:get-test-info-by-id run-id test-id))
	 (test-name   (db:test-get-testname  testdat))
︙

Modified utils/plot-code.scm from [903f29a75e] to [34a7dae9ed].

︙
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

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








+















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








(define (print-err . data)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print data))))

(print-err "Making graph for files: " (string-intersperse targs ", "))
(print-err "Looking at files: " (string-intersperse files ", "))
(print-err "Function regex: " function-patt)

;; Gather the functions
;;
(for-each 
 (lambda (fname)
   (print-err "Processing file " fname)
   (with-input-from-file fname
     (lambda ()
       (let loop ((inl (read-line)))
	 (if (not (eof-object? inl))
	     (let ((match (string-match defn-rx inl)))
	       (if match 
		   (let ((fnname (cadr match)))
		     ;; (print "   " fnname)
		     (if (string-match function-rx fnname)
			 (begin
			 (set! all-fns (cons fnname all-fns)))
		     (hash-table-set! 
		      filedat-defns 
		      fname
		      (cons fnname (hash-table-ref/default filedat-defns fname '())))
		     ))
			   (set! all-fns (cons fnname all-fns)))
			 (hash-table-set! 
			  filedat-defns 
			  fname
			  (cons fnname (hash-table-ref/default filedat-defns fname '())))
			 )))
	       (loop (read-line))))))))
 files)

;; fill up the regex hash
(print-err "Make the huge regex hash")
(for-each
 (lambda (fnname)
︙

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