Megatest

Diff
Login

Differences From Artifact [b74957e222]:

To Artifact [9b3f9a0905]:


100
101
102
103
104
105
106
107

108
109
110


111
112
113


114
115
116
117
118
119
120
100
101
102
103
104
105
106

107
108


109
110
111


112
113
114
115
116
117
118
119
120







-
+

-
-
+
+

-
-
+
+







  (db          #f)    ;; should rename this to oddb for on disk db
  (inmem       #f)
  (last-sync   0)
  (last-write  (current-seconds))
  (run-id      #f)
  (fname       #f))
  
;; Returns the dbdat for a particular run-id from dbstruct
;; Returns the dbdat for a particular dbfile inside the area
;;
(define (dbr:dbstruct-get-dbdat v run-id)
  (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f))
(define (dbr:dbstruct-get-dbdat dbstruct dbfile)
  (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))

(define (dbr:dbstruct-dbdat-put! v run-id db)
  (hash-table-set! (dbr:dbstruct-dbdats v) run-id db))
(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
  (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))

(define (db:run-id->first-num run-id)
  (let* ((s (number->string run-id))
	 (l (string-length s)))
    (substring s (- l 1) l)))

;; 1234 => 4/1234.db
153
154
155
156
157
158
159
160

161
162
163
164

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184

185
186
187
188
189
190
191
192
193
194
195
196
197

198
199
200
201
202
203
204
153
154
155
156
157
158
159

160
161
162


163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181


182
183
184
185
186
187
188
189
190
191
192
193


194
195
196
197
198
199
200
201







-
+


-
-
+


















-
-
+











-
-
+







;;    if run-id => get run specific db
;;    if #f     => get main.db
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (db:get-dbdat dbstruct apath dbfile)
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id)))
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile)))
    (if dbdat
	dbdat
	(let* (;; (dbfile   (db:run-id->path apath run-id))
	       (newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
	(let* ((newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
	  (dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat)
	  newdbdat))))

;; get the inmem db for actual db operations
;;
(define (db:get-inmem dbstruct apath dbfile)
  (dbr:dbdat-inmem (db:get-dbdat dbstruct apath dbfile)))

;; get the handle for the on-disk db
;;
(define (db:get-ddb dbstruct apath dbfile)
  (dbr:dbdat-db (db:get-dbdat dbstruct apath dbfile)))

;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;; 
(define (db:open-dbdat apath dbfile dbinit-proc)
  (let* (;; (dbfile   (db:run-id->path apath run-id))
	 (db       (db:open-run-db dbfile dbinit-proc))
  (let* ((db       (db:open-run-db dbfile dbinit-proc))
	 ;; (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (make-dbr:dbdat
		    db:     #f ;; db
		    inmem:  db ;; inmem
		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
		    fname:  dbfile)))
    ;; now sync the disk file data into the inmemory db
    ;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
    ;; (sqlite3:finalize! db) ;; open and close every sync
    dbdat))
;; (define (db:open-dbdat apath dbfile dbinit-proc)
;;   (let* (;; (dbfile   (db:run-id->path apath run-id))
;; 	 (db       (db:open-run-db dbfile dbinit-proc))
;;   (let* ((db       (db:open-run-db dbfile dbinit-proc))
;; 	 (inmem    (db:open-inmem-db dbinit-proc))
;; 	 (dbdat    (make-dbr:dbdat
;; 		    db:     #f ;; db
;; 		    inmem:  inmem
;; 		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
;; 		    fname:  dbfile)))
;;     ;; now sync the disk file data into the inmemory db
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249














250
251
252
253
254
255
256
257
258
259
260
261
262

263
264
265
266
267
268
269
270
226
227
228
229
230
231
232














233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258

259

260
261
262
263
264
265
266







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












-
+
-







(define (db:open-inmem-db dbinit-proc)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler (sqlite3:make-busy-timeout 3600)))
    (sqlite3:set-busy-handler! db handler)
    (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db)
    db))

;; for debugging we have a local mode. these routines support that mode
(define *dbcache* (make-hash-table))

(define (db:cache-get-dbstruct rid apath)
  (let* ((dbname (db:run-id->dbname rid))
	 (dbfile (db:dbname->path apath dbname)))
    (or (hash-table-ref/default *dbcache* dbfile #f)
	(let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
	  (hash-table-set! *dbcache* dbfile dbstruct)
	  dbstruct))))

(define (db:finalize-all-cache-dbstruct)
  #f)
	  
;; ;; for debugging we have a local mode. these routines support that mode
;; (define *dbcache* (make-hash-table))
;; 
;; (define (db:cache-get-dbstruct rid apath)
;;   (let* ((dbname (db:run-id->dbname rid))
;; 	 (dbfile (db:dbname->path apath dbname)))
;;     (or (hash-table-ref/default *dbcache* dbfile #f)
;; 	(let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
;; 	  (hash-table-set! *dbcache* dbfile dbstruct)
;; 	  dbstruct))))
;; 
;; (define (db:finalize-all-cache-dbstruct)
;;   #f)
;; 	  

;; get and initalize dbstruct for a given run-id
;;
;;  - uses db:initialize-db to create the schema
;;
;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup db-file) ;; run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
	 #;(db-file  (db:run-id->path *toppath* run-id)))
    (db:get-dbdat dbstruct *toppath* db-file)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    dbstruct))

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;
1194
1195
1196
1197
1198
1199
1200
1201

1202
1203

1204
1205
1206
1207
1208
1209
1210
1211
1212

1213
1214

1215
1216
1217
1218
1219
1220
1221
1190
1191
1192
1193
1194
1195
1196

1197
1198

1199
1200
1201
1202
1203
1204
1205
1206
1207

1208
1209

1210
1211
1212
1213
1214
1215
1216
1217







-
+

-
+








-
+

-
+







	   (list "update_test_data_trigger"  "CREATE TRIGGER  IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE test_data SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;" )))

(define (db:create-all-triggers dbstruct)
(define (db:create-all-triggers dbstruct run-id)
(db:with-db
   dbstruct #f #f
   dbstruct run-id #f
   (lambda (db)
(db:create-triggers db))))

(define (db:create-triggers db)
    (for-each (lambda (key)
              (sqlite3:execute db (cadr key)))
          db:trigger-list))

(define (db:drop-all-triggers dbstruct)
(define (db:drop-all-triggers dbstruct run-id)
  (db:with-db
   dbstruct #f #f
   dbstruct run-id #f
   (lambda (db)
     (db:drop-triggers db))))

(define (db:is-trigger-dropped db tbl-name)
  (let* ((trigger-name (if (equal? tbl-name "test_steps")
			   "update_teststeps_trigger" 
                           (conc "update_" tbl-name "_trigger")))
1640
1641
1642
1643
1644
1645
1646
1647

1648
1649
1650
1651
1652
1653
1654
1636
1637
1638
1639
1640
1641
1642

1643
1644
1645
1646
1647
1648
1649
1650







-
+







	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   72000))) ;; twenty hours
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
       
       ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
       ;;
       ;; HOWEVER: this code in run:test seems to work fine
       ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
1723
1724
1725
1726
1727
1728
1729
1730

1731
1732
1733
1734
1735
1736
1737
1719
1720
1721
1722
1723
1724
1725

1726
1727
1728
1729
1730
1731
1732
1733







-
+







         (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
         (running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
         )
    (debug:print-info 4  *default-log-port* "running-deadtime = " running-deadtime)
    (debug:print-info 4  *default-log-port* "deadtime-trim = " deadtime-trim)

    (db:with-db 
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (let* ((stmth1 (db:get-cache-stmth
		       dbstruct db
		       "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests 
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
                                          AND state IN ('RUNNING');"))
	      (stmth2 (db:get-cache-stmth
1845
1846
1847
1848
1849
1850
1851
1852

1853
1854
1855
1856
1857
1858
1859
1841
1842
1843
1844
1845
1846
1847

1848
1849
1850
1851
1852
1853
1854
1855







-
+







		 ;; MATT: Moving this to rmt.scm - call right after calling find-and-mark-complete
		 ;; (launch:end-of-run-check run-id)
		 )))))))

;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
  (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
  (db:general-call dbstruct 'top-test-set-per-pf-counts run-id (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))

;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
1995
1996
1997
1998
1999
2000
2001
2002

2003
2004
2005
2006

2007
2008
2009

2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023


2024
2025
2026
2027
2028


2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045


2046
2047
2048
2049
2050


2051
2052
2053
2054
2055


2056
2057
2058
2059
2060
2061
2062
1991
1992
1993
1994
1995
1996
1997

1998
1999
2000
2001

2002
2003
2004

2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017


2018
2019
2020
2021
2022


2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039


2040
2041
2042
2043
2044


2045
2046
2047
2048
2049


2050
2051
2052
2053
2054
2055
2056
2057
2058







-
+



-
+


-
+












-
-
+
+



-
-
+
+















-
-
+
+



-
-
+
+



-
-
+
+







;;     ;; (db:delay-if-busy dbdat)
;;     (sqlite3:execute db "VACUUM;")
;;     dead-runs))

;;======================================================================
;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

   
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
(define (db:get-var dbstruct var)
(define (db:get-var dbstruct run-id var)
  (let* ((res      #f))
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (sqlite3:for-each-row
        (lambda (val)
          (set! res val))
        db
        "SELECT val FROM metadat WHERE var=?;" var)
       ;; convert to number if can
       (if (string? res)
           (let ((valnum (string->number res)))
             (if valnum (set! res valnum))))
       res))))

(define (db:inc-var dbstruct var)
  (db:with-db dbstruct #f #t 
(define (db:inc-var dbstruct run-id var)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))

(define (db:dec-var dbstruct var)
  (db:with-db dbstruct #f #t 
(define (db:dec-var dbstruct run-id var)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))

;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;;     (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; 						 (if throttle throttle 0.01)))
;; 			    2))
;;     (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
;; 	(begin
;; 	  (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; 	  (set! *last-global-delta-printed* *global-delta*)))

(define (db:set-var dbstruct var val)
  (db:with-db dbstruct #f #t 
(define (db:set-var dbstruct run-id var val)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))

(define (db:add-var dbstruct var val)
  (db:with-db dbstruct #f #t 
(define (db:add-var dbstruct run-id var val)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))

(define (db:del-var dbstruct var)
  (db:with-db dbstruct #f #t 
(define (db:del-var dbstruct run-id var)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================

2276
2277
2278
2279
2280
2281
2282
2283

2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300

2301
2302
2303
2304
2305
2306
2307
2272
2273
2274
2275
2276
2277
2278

2279

2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294

2295
2296
2297
2298
2299
2300
2301
2302







-
+
-















-
+







		    qryvals)
	     (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	     res))) 
	(begin
	  (debug:print-error 0 *default-log-port* "Called without all necessary keys")
	  #f))))

;; register a test run with the db, this accesses the main.db and does NOT
;; register a run with the db
;; use server api
;;
(define (db:insert-run dbstruct run-id keyvals runname state status user contour-in)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))
	 (contour   (or contour-in ""))  ;; empty string to force no hierarcy and be backwards compatible.
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (allvals   (append (list runname state status user contour) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
    (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(db:with-db
	 dbstruct #f #f
	 dbstruct run-id #f
	 (lambda (db)
	   (let ((res #f))
	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    run-id
		    allvals)
	     (apply sqlite3:for-each-row 
		    (lambda (id)
2519
2520
2521
2522
2523
2524
2525
2526

2527
2528
2529
2530
2531
2532
2533
2514
2515
2516
2517
2518
2519
2520

2521
2522
2523
2524
2525
2526
2527
2528







-
+







;; 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*)
  (db:with-db
   dbstruct
   #f
   run-id
   #f

   (lambda (db)
     ;; remove previous data
     
     (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
	    (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
3076
3077
3078
3079
3080
3081
3082
3083
3084


3085
3086

3087
3088
3089
3090
3091
3092
3093
3071
3072
3073
3074
3075
3076
3077


3078
3079
3080

3081
3082
3083
3084
3085
3086
3087
3088







-
-
+
+

-
+







	 (db:get-all-run-ids dbstruct)))
    res))

;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;

(define (db:delete-test-records dbstruct run-id test-id)
  (db:general-call dbstruct 'delete-test-step-records (list test-id))
  (db:general-call dbstruct 'delete-test-data-records (list test-id))
  (db:general-call dbstruct 'delete-test-step-records run-id (list test-id))
  (db:general-call dbstruct 'delete-test-data-records run-id (list test-id))
  (db:with-db
   dbstruct #f #f
   dbstruct run-id #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))

;; 
(define (db:delete-old-deleted-test-records dbstruct)
  (let ((targtime (- (current-seconds)
		     (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
3138
3139
3140
3141
3142
3143
3144


3145
3146
3147

3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163










3164
3165
3166
3167
3168
3169
3170
3171
3172
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143

3144
















3145
3146
3147
3148
3149
3150
3151
3152
3153
3154


3155
3156
3157
3158
3159
3160
3161







+
+


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







	       (mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
     testnames)
    test-ids))

;; ;; 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
;;
;; NOTE: processing triggers was called here - moved upstream
;;
;;      NOTE: run-id is not used
;; ;;
(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
(define (db:test-set-state-status db run-id test-id newstate newstatus newcomment)
  (db:with-db
   dbstruct
   ;; run-id
   #f
   #t
   (lambda (db)
     (cond
      ((and newstate newstatus newcomment)
       (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
			test-id))
      ((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)
  (cond
   ((and newstate newstatus newcomment)
    (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
		     test-id))
   ((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 test-id)))))
				       test-id))))))
  (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) ;; fastmode)
  (let* ((qry ;; (if fastmode
		;;   "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")) ;; )
3615
3616
3617
3618
3619
3620
3621
3622

3623
3624

3625
3626
3627
3628
3629
3630
3631
3604
3605
3606
3607
3608
3609
3610

3611
3612

3613
3614
3615
3616
3617
3618
3619
3620







-
+

-
+







	  (set! fail-count fcount)
	  (set! pass-count pcount))
	db 
	"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
             (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
	test-id test-id)
       ;; Now rollup the counts to the central megatest.db
       (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
       (db:general-call dbstruct 'pass-fail-counts run-id (list pass-count fail-count test-id))
       ;; if the test is not FAIL then set status based on the fail and pass counts.
       (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
       (db:general-call dbstruct 'test_data-pf-rollup run-id (list test-id test-id test-id test-id))))))

;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
;; section LogFileBody
;; desc Output voltage
3922
3923
3924
3925
3926
3927
3928
3929
3930


3931
3932

3933
3934
3935
3936
3937
3938

3939

3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951



3952
3953
3954
3955

3956
3957
3958




3959
3960
3961
3962
3963
3964
3965
3911
3912
3913
3914
3915
3916
3917


3918
3919
3920

3921
3922
3923
3924
3925
3926
3927
3928

3929
3930
3931
3932
3933
3934
3935
3936
3937
3938



3939
3940
3941
3942
3943
3944

3945
3946
3947

3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958







-
-
+
+

-
+






+
-
+









-
-
-
+
+
+



-
+


-
+
+
+
+







			   test-name))
	 (item-path    (db:test-get-item-path testdat))
         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
         (tl-test-id   (if tl-testdat
			   (db:test-get-id tl-testdat)
			   #f)))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
	(db:general-call dbstruct 'set-test-start-time (list test-id)))
    (mutex-lock! *db-transaction-mutex*)
	(db:general-call dbstruct 'set-test-start-time run-id (list test-id)))
    ;; (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
		  ;; this call sets the item state/status
                 (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
                 (db:test-set-state-status db 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 dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
			      						  (state-stauses (db:roll-up-rules state-status-counts state status))
                          (newstate (car state-stauses))
                          (newstatus (cadr state-stauses)))
                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts)  " state-status-counts: "
							(apply conc
                  (map (lambda (x)
                     (conc
                     		(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
                              state-status-counts))); end debug:print
   
		      (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
		       state-status-counts))); end debug:print
		       
                       (if tl-test-id
			   (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       ))))))
         (mutex-unlock! *db-transaction-mutex*)
         ;; (mutex-unlock! *db-transaction-mutex*)
         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
         tr-res)))))
         tr-res)))
    ;; this was moved out of test-set-state-status
    (mt:process-triggers dbstruct run-id test-id state status)))


(define (db:roll-up-rules state-status-counts state status)
		(let* ((running     (length (filter (lambda (x)
                          (member (dbr:counts-state x) *common:running-states*))
                                 state-status-counts)))
           (bad-not-started      (length (filter (lambda (x)
                                      (and (equal? (dbr:counts-state x) "NOT_STARTED") 
4010
4011
4012
4013
4014
4015
4016
4017

4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031

4032
4033
4034
4035
4036
4037
4038
4003
4004
4005
4006
4007
4008
4009

4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023

4024
4025
4026
4027
4028
4029
4030
4031







-
+













-
+







                                         "\n--> newstatus            "newstatus
                                         "\n\n")

                        ;; NB// Pass the db so it is part of the transaction
         (list newstate newstatus)))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
    (mutex-lock! *db-transaction-mutex*)
  ;; (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                   (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
													(state-stauses (db:roll-up-rules state-status-counts #f #f ))
                          (newstate (car state-stauses))
                          (newstatus (cadr state-stauses))) 
                    (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
                   (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
         (mutex-unlock! *db-transaction-mutex*)
         ;; (mutex-unlock! *db-transaction-mutex*)
         tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
 (let* ((test-count-recs (db:with-db
                                  dbstruct #f #f
                                  (lambda (db)
4286
4287
4288
4289
4290
4291
4292
4293

4294
4295
4296
4297
4298
4299
4300

4301
4302
4303
4304
4305
4306
4307
4279
4280
4281
4282
4283
4284
4285

4286
4287
4288
4289
4290
4291
4292

4293
4294
4295
4296
4297
4298
4299
4300







-
+






-
+







   ((not (equal? megatest-version calling-version))
    (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
   
    (else
    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
    '(#t "successful login"))))

(define (db:general-call dbstruct stmtname params)
(define (db:general-call dbstruct stmtname run-id params)
  (let ((query (let ((q (alist-ref (if (string? stmtname)
				       (string->symbol stmtname)
				       stmtname)
				   db:queries)))
 		 (if q (car q) #f))))
    (db:with-db
     dbstruct #f #f
     dbstruct run-id #f
     (lambda (db)
       (apply sqlite3:execute db query params)
       #t))))

;; get a summary of state and status counts to calculate a rollup
;;
(define (db:get-state-status-summary dbstruct run-id testname)
5209
5210
5211
5212
5213
5214
5215
5216

5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232


5233
5234
5235
5236
5237
5238
5239
5202
5203
5204
5205
5206
5207
5208

5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223


5224
5225
5226
5227
5228
5229
5230
5231
5232







-
+














-
-
+
+







			test-name     " "
			item-path     " " ;; has / prepended to deal with toplevel tests
			actual-state  " "
			actual-status " "
			event-time
			))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
    (set-environment-variable! "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-writable? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-writable? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    ;; (call-with-environment-variables
    ;;  `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
    ;;  (lambda ()
    (process-run fullcmd)
    (if prev-nbfake-log
	(setenv "NBFAKE_LOG" prev-nbfake-log)
	(unsetenv "NBFAKE_LOG"))
	(set-environment-variable! "NBFAKE_LOG" prev-nbfake-log)
	(unset-environment-variable! "NBFAKE_LOG"))
    )) ;; ))

(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
  (if test-id 
      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
	(if test-dat
	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )
5301
5302
5303
5304
5305
5306
5307
5308

5309
5310
5311
5312
5313


5314
5315
5316
5317
5318
5319
5320
5294
5295
5296
5297
5298
5299
5300

5301
5302
5303
5304


5305
5306
5307
5308
5309
5310
5311
5312
5313







-
+



-
-
+
+







	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? tconfig-file)
		       (file-readable? tconfig-file))
		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
			(old-link-tree  (get-environment-variable "MT_LINKTREE"))
			(bigmodenv      (module-environment 'bigmod)))
		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
		    (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path))
		    (let ((newtcfg (configf:read-config tconfig-file #f #f env-to-use: bigmodenv))) ;; NOTE: Does NOT run [system ...]
		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)
			  (unsetenv "MT_LINKTREE"))
			  (set-environment-variable! "MT_LINKTREE" old-link-tree)
			  (unset-environment-variable! "MT_LINKTREE"))
		      newtcfg))
		  (if (null? tal)
		      (begin
			(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
			#f)
		      (loop (car tal)(cdr tal))))))))))