Megatest

Check-in [0d46185eb4]
Login
Overview
Comment:bunch of small clean up
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: 0d46185eb4d6fa1efa96db1676c4f85b7cb84930
User & Date: matt on 2021-04-16 22:44:36
Other Links: branch diff | manifest | tags
Context
2021-04-17
00:24
Moved bunch of remaining non-modularized procs into modules check-in: a4b25b8489 user: matt tags: v1.6584-ck5
2021-04-16
22:44
bunch of small clean up check-in: 0d46185eb4 user: matt tags: v1.6584-ck5
03:17
wip check-in: dd2b8adfb2 user: matt tags: v1.6584-ck5
Changes

Modified commonmod.scm from [c02961cc89] to [96d2090959].

97
98
99
100
101
102
103





104
105
106
107
108
109
110
111
112
113
114
115
116
117



118
119
120
121
122
123
124
125
126
127
128
129
130
131










132
133
134
135
136
137
138
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156







+
+
+
+
+














+
+
+














+
+
+
+
+
+
+
+
+
+







(include "db_records.scm")

;; these come from processmod
;;
;; (define setenv set-environment-variable!)
;; (define unsetenv unset-environment-variable!)
;; (define getenv get-environment-variable)

;; move all the miscellanea into this struct
;;
(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target)


(define *bdat* #f) ;; the one and only (someday) global?

(defstruct bdat
  (home                   (getenv "HOME"))
  (user                   (getenv "USER"))
  (watchdog               #f)
  (time-to-exit           #f)
  (task-db                #f)
  (target                 #f)
  (this-exe-fullpath      #f)
  (this-exe-dir           #f)
  (this-exe-name          #f)
  (orig-env               #f)

  ;; runs stuff
  (runs-data              #f) ;; was runs:general-data
  ;; (server-loop-heart-beat (current-seconds))
  )

;; move all needed initialization into here
;; break it into pieces if need be later
;;
(define (make-and-init-bigdata)
  (let* ((bdat 	(make-bdat))
	 (fullp (common:get-this-exe-fullpath)))
    ;; bdat stuff
    (bdat-this-exe-fullpath-set! bdat fullp)
    (bdat-this-exe-dir-set! bdat (pathname-directory fullp))
    (bdat-this-exe-name-set! bdat (pathname-strip-directory fullp))
    (bdat-orig-env-set! bdat (get-the-original-environment))
    ;; setup runs-data
    (bdat-runs-data-set! bdat  (make-runs:gendat
				inc-results: (make-hash-table)
				inc-results-last-update: 0
				;;               state status time duration test-name item-path
				inc-results-fmt: "~12a~12a~20a~12a~40a\n"
				run-info: #f
				runname: #f
				target: #f))
    
    (set! *bdat* bdat)
    ;; set up signal handlers
    (set-signal-handler! signal/int  std-signal-handler)  ;; ^C
    (set-signal-handler! signal/term std-signal-handler)
    ;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!
    bdat))

330
331
332
333
334
335
336

































337
338
339
340
341
342
343
348
349
350
351
352
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
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







;; D E B U G G I N G   S T U F F 
;;======================================================================

(define *verbosity*         1)
(define *logging*           #f)

(define *common:thread-punchlist* (make-hash-table))

(define *last-num-running-tests* 0)
(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run
(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran

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

(define *max-tries-hash* (make-hash-table))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define *db:process-queue-mutex* (make-mutex))
(define *http-functions* (make-hash-table))
(define *http-mutex* (make-mutex))

;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
;;       I'm pretty sure it is defunct.

;; This next block all imported en-mass from the api branch
(define *http-requests-in-progress* 0)
(define *http-connections-next-cleanup* (current-seconds))

(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;; 
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
;; (define db:dbfile-path common:get-db-tmp-area)
(define *global-db-store* (make-hash-table))


;;======================================================================
;; end globals
;;======================================================================

;;                       0           1              2              3
(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0))

Modified dbmod.scm from [7f27b118d2] to [1e9887ecf4].

94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
94
95
96
97
98
99
100



101
102
103
104
105
106
107







-
-
-







;; 
;; (include "common_records.scm")

;; (include "db_records.scm")
(include "key_records.scm")
;; (include "run_records.scm")

(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

;;======================================================================
;;  R E C O R D S
;;======================================================================

;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
206
207
208
209
210
211
212
213

214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230

231
232
233

234
235
236
237
238
239
240
203
204
205
206
207
208
209

210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226

227
228
229

230
231
232
233
234
235
236
237







-
+
















-
+


-
+







;;    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-db dbstruct) ;;  run-id) 
  (if (stack? (dbr:dbstruct-dbstack dbstruct))
      (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
          (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
          (let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area))))
            ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
            newdb)
          (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
      (db:open-db dbstruct)))

;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
  (if (pair? dbdat)
      (car dbdat)
      dbdat))

(define (db:dbdat-get-path dbdat)
  (if (pair? dbdat)
      (cdr dbdat)
      #f))

(define-inline (db:generic-error-printout exn . message)
(define (db:generic-error-printout exn . message)
  (print-call-chain (current-error-port))
  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* "   params: " params
  (debug:print-error 0 *default-log-port* ;; "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
		     ))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
291
292
293
294
295
296
297







298
299
300
301
302
303
304







-
-
-
-
-
-
-







;; 
;; ;; Use to get a path. To get an arbitrary string see next define
;; ;;
;; (define (db:get-path dbstruct id)
;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;; 
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
(define db:dbfile-path common:get-db-tmp-area)

(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) 

;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
388
389
390
391
392
393
394
395

396
397
398
399
400
401
402
378
379
380
381
382
383
384

385
386
387
388
389
390
391
392







-
+







;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
  (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
    (if (stack? tmpdb-stack)
	(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
        (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
               (dbpath       (db:dbfile-path ))      ;; path to tmp db area
               (dbpath       (common:get-db-tmp-area ))      ;; path to tmp db area
               (dbexists     (common:file-exists? dbpath))
	       (tmpdbfname   (conc dbpath "/megatest.db"))
	       (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
               (mtdbexists   (common:file-exists? (conc *toppath* "/megatest.db")))
							 
               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db"))   #f))
	        		 (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1044
1045
1046
1047
1048
1049
1050


1051
1052
1053
1054
1055
1056
1057







-
-







	 ;; fill in blanks (not allowed as it would be part of the path
	 (sqlite3:execute
	  db
	  (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
	 (set! field-num (+ field-num 1))))
     fields)))
  
(define *global-db-store* (make-hash-table))

(define (db:get-access-mode)
  (if (args:get-arg "-use-db-cache") 'cached 'rmt))

;; Add db direct
;;
(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
  (if (eq? access-mode 'cached)
2212
2213
2214
2215
2216
2217
2218
2219

2220
2221
2222
2223
2224
2225
2226
2200
2201
2202
2203
2204
2205
2206

2207
2208
2209
2210
2211
2212
2213
2214







-
+







		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

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

(define (db:open-no-sync-db)
  (let* ((dbpath (db:dbfile-path))
  (let* ((dbpath (common:get-db-tmp-area))
	 (dbname (conc dbpath "/no-sync.db"))
	 (db-exists (common:file-exists? dbname))
	 (db     (sqlite3:open-database dbname)))
    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
    (if (not db-exists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = 0;")
2520
2521
2522
2523
2524
2525
2526
2527

2528
2529
2530
2531
2532
2533
2534
2508
2509
2510
2511
2512
2513
2514

2515
2516
2517
2518
2519
2520
2521
2522







-
+







		   )))
    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    res))

;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
(define (db:get-changed-run-ids since-time)
  (let* ((dbdir      (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
  (let* ((dbdir      (common:get-db-tmp-area)) ;; (configf:lookup *configdat* "setup" "dbdir"))
	 (alldbs     (glob (conc dbdir "/[0-9]*.db")))
	 (changed    (filter (lambda (dbfile)
			       (> (file-modification-time dbfile) since-time))
			     alldbs)))
    (delete-duplicates
     (map (lambda (dbfile)
	    (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
3445
3446
3447
3448
3449
3450
3451

3452
3453
3454
3455
3456
3457
3458
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447







+







		 (indx 0))
	(if (equal? fieldname hed)
	    indx
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)(+ indx 1)))))))

;; CONVERT THIS TO A FUNCTION!
(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))

(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
  (db:with-db
   dbstruct   #f   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"

Modified http-transportmod.scm from [03a411c806] to [3ef9978756].

120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
120
121
122
123
124
125
126


127
128
129
130
131
132
133







-
-







;;======================================================================
;; S E R V E R
;; ======================================================================

;; Call this to start the actual server
;;

(define *db:process-queue-mutex* (make-mutex))
(define *http-functions* (make-hash-table))
(define (http-get-function fnkey)
  (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))

(define (http-transport:run hostn)
  ;; Configurations for server
  (tcp-buffer-size 2048)
  (max-connections 2048) 
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
253
254
255
256
257
258
259








260
261
262
263
264
265
266







-
-
-
-
-
-
-
-







;; S E R V E R   U T I L I T I E S 
;;======================================================================

;;======================================================================
;; C L I E N T S
;;======================================================================

(define *http-mutex* (make-mutex))

;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
;;       I'm pretty sure it is defunct.

;; This next block all imported en-mass from the api branch
(define *http-requests-in-progress* 0)
(define *http-connections-next-cleanup* (current-seconds))

(define (http-transport:get-time-to-cleanup)
  (let ((res #f))
    (mutex-lock! *http-mutex*)
    (set! res (> (current-seconds) *http-connections-next-cleanup*))
    (mutex-unlock! *http-mutex*)
    res))

Modified rmtmod.scm from [ce483e1308] to [987241e2e4].

141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
141
142
143
144
145
146
147


148
149
150
151
152
153
154







-
-







	      cinfo
	      (if (server:check-if-running areapath)
		  (client:setup areapath)
		  #f))))

;;======================================================================

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected

  #;(common:telemetry-log (conc "rmt:"(->string cmd))
                        payload: `((rid . ,rid)
                                   (params . ,params)))
451
452
453
454
455
456
457
458

459
460
461
462
463
464
465
449
450
451
452
453
454
455

456
457
458
459
460
461
462
463







-
+







				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
	 (db-file-path   (db:dbfile-path)) ;;  0))
	 (db-file-path   (common:get-db-tmp-area)) ;;  0))
	 (dbstruct-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only      (not (file-writable? db-file-path)))
	 (start          (current-milliseconds))
	 (resdat         (if (not (and read-only qry-is-write))
			     (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
			       (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
				exn               ;;  This is an attempt to detect that situation and recover gracefully

Modified runsmod.scm from [4aa37d6c17] to [6d3e5322d2].

205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
205
206
207
208
209
210
211

212
213
214
215
216
217
218
219
220
221
222
223
224

225
226
227
228
229
230
231


232
233
234
235
236
237
238







-













-







-
-







      (debug:print-info 0 *default-log-port* "DONE: rtime=" rtime ", elapsed time=" (- done-time startt)
			", ratio=" (/ rtime (- done-time startt))))))

;; Every time can-run-more-tests is called increment the delay
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)
;; (define *runs:can-run-more-tests-count* 0)
(define (runs:shrink-can-run-more-tests-count runsdat)
  (runs:dat-can-run-more-tests-count-set! runsdat 0))

(define (runs:inc-can-run-more-tests-count runsdat)
  (runs:dat-can-run-more-tests-count-set!
   runsdat
   (+ (runs:dat-can-run-more-tests-count runsdat) 1)))

;;  (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2)))

;; Temporary globals. Move these into the logic or into common
;;
(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run
(define (runs:inc-cant-run-tests testname)
  (hash-table-set! *seen-cant-run-tests* testname
		   (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1)))

(define (runs:can-keep-running? testname n)
  (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n))

(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran

;; mechanism to limit printing info to the screen that is repetitive.
;;
;; Example: 
;; (if (runs:lownoise "waiting on tasks" 60)
;;     (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
;;
(define (runs:lownoise key waitval)
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274




1275
1276
1277


1278
1279
1280

1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303







1304
1305
1306
1307

1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319

1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331

1332
1333
1334
1335

1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1246
1247
1248
1249
1250
1251
1252















1253


1254
1255
1256
1257
1258


1259
1260
1261
1262

1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279







1280
1281
1282
1283
1284
1285
1286
1287
1288
1289

1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301

1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313

1314
1315
1316
1317

1318
1319
1320
1321
1322
1323
1324

1325
1326
1327
1328
1329
1330
1331







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

-
-
+
+
+
+

-
-
+
+


-
+
















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



-
+











-
+











-
+



-
+






-







		     (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" ))
			 #f
			 t))
		    ((DELETED) #f)
		    (else t)))))
	  tests))

;; move all the miscellanea into this struct
;;
(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target)

(define *runs:general-data* 
  (make-runs:gendat
   inc-results: (make-hash-table)
   inc-results-last-update: 0
   inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path
   run-info: #f
   runname: #f
   target: #f
   )
  )

(define (runs:incremental-print-results run-id)
  (let ((curr-sec    (current-seconds))
	(last-update (runs:gendat-inc-results-last-update *runs:general-data*)))
  (let* ((curr-sec    (current-seconds))
	 (runs-data   (bdat-runs-data *bdat*))
	 (last-update (runs:gendat-inc-results-last-update runs-data))
	 (runs-data   (bdat-runs-data *bdat*)))
    (if (> (- curr-sec last-update) 5) ;; at least five seconds since last update
	(let* ((run-dat  (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id)))
	       (runname  (or (runs:gendat-runname *runs:general-data*)
	(let* ((run-dat  (or (runs:gendat-run-info runs-data)(rmt:get-run-info run-id)))
	       (runname  (or (runs:gendat-runname runs-data)
			     (db:get-value-by-header (db:get-rows run-dat)
						     (db:get-header run-dat) "runname")))
	       (target   (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id)))
	       (target   (or (runs:gendat-target runs-data)(rmt:get-target run-id)))
	       (testsdat (let ((res (rmt:get-tests-for-run
				     run-id "%" '() '() ;; run-id testpatt states statuses
				     #f #f ;; offset limit
				     #f ;; not-in
				     #f ;; sort-by
				     #f ;; sort-order
				     #f ;; get full data (not 'shortlist)
				     last-update
				     'dashboard)))
			   (if (list? res)
			       res
			       (begin
				 (debug:print-error
				  0 *default-log-port*
				  "FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res)
				 '())))))
	  (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 1))
	  (if (not (runs:gendat-run-info *runs:general-data*))
	      (runs:gendat-run-info-set! *runs:general-data* run-dat))
	  (if (not (runs:gendat-runname  *runs:general-data*))
	      (runs:gendat-runname-set! *runs:general-data* runname))
	  (if (not (runs:gendat-target *runs:general-data*))
	      (runs:gendat-target-set! *runs:general-data* target))
	  (runs:gendat-inc-results-last-update-set! runs-data (- curr-sec 1))
	  (if (not (runs:gendat-run-info runs-data))
	      (runs:gendat-run-info-set! runs-data run-dat))
	  (if (not (runs:gendat-runname  runs-data))
	      (runs:gendat-runname-set! runs-data runname))
	  (if (not (runs:gendat-target runs-data))
	      (runs:gendat-target-set! runs-data target))
	  (for-each
	   (lambda (testdat)
	     (let* ((test-id    (db:test-get-id           testdat))
		    (prevdat    (hash-table-ref/default   (runs:gendat-inc-results *runs:general-data*)
		    (prevdat    (hash-table-ref/default   (runs:gendat-inc-results runs-data)
							  (conc run-id "," test-id) #f))
		    (test-name  (db:test-get-testname     testdat))
		    (item-path  (db:test-get-item-path    testdat))
		    (state      (db:test-get-state        testdat))
		    (status     (db:test-get-status       testdat))
		    (event-time (db:test-get-event_time   testdat))
		    (duration   (db:test-get-run_duration testdat)))
	       (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED")))
			(not (and prevdat
				  (equal? state  (db:test-get-state  prevdat))
				  (equal? status (db:test-get-status prevdat)))))
		   (let ((fmt   (runs:gendat-inc-results-fmt *runs:general-data*))
		   (let ((fmt   (runs:gendat-inc-results-fmt runs-data))
			 (dtime (seconds->year-work-week/day-time event-time))) 
		     (if (runs:lownoise "inc-print" 600)
			 (format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))
		     ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime)
		     ;; (debug:print 0 #f "event-time: " event-time " duration: " duration)
		     (format #t fmt
			     state
			     status
			     dtime
			     (seconds->hr-min-sec duration)
			     (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path))))
		     (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat)))))
		     (hash-table-set! (runs:gendat-inc-results runs-data) (conc run-id "," test-id) testdat)))))
	   testsdat)))

    ;; I don't think this should be here? -- Matt
    #;(runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10))
    #;(runs:gendat-inc-results-last-update-set! runs-data (- curr-sec 10))

    ))

;; every time though the loop increment the test/itempatt val.
;; when the min is > max-allowed and none running then force exit
;;
(define *max-tries-hash* (make-hash-table))

(define (runs:pretty-long-list lst)
   (if (> (length lst) 8)(append (take lst 3)(list "...")) lst))

;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================

Modified tasksmod.scm from [9c13d78f35] to [cab097b87f].

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







-
+







	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))
	     (thread-sleep! 1)
	     (tasks:open-db numretries (- numretries 1)))
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))))
       (let* ((dbpath        (db:dbfile-path )) ;; (tasks:get-task-db-path))
       (let* ((dbpath        (common:get-db-tmp-area )) ;; (tasks:get-task-db-path))
	      (dbfile       (conc dbpath "/monitor.db"))
	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
	      (exists       (common:file-exists? dbpath))
	      (write-access (file-writable? dbpath))
	      (mdb          (cond ;; what the hek is *toppath* doing here?
			     ((and (string? *toppath*)(file-writable? *toppath*))
			      (sqlite3:open-database dbfile))
322
323
324
325
326
327
328
329

330
331
332
333
334
335
336
322
323
324
325
326
327
328

329
330
331
332
333
334
335
336







-
+







    res))

;; 
#;(define (tasks:start-monitor db mdb)
  (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
      (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
	     (monitordbf     (conc (db:dbfile-path #f) "/monitor.db"))
	     (monitordbf     (conc (common:get-db-tmp-area) "/monitor.db"))
	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
	(task:register-monitor mdb)
	(let loop ((count      0)
		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
	  ;; if the db has been modified we'd best look at the task queue
	  (let ((modtime (file-modification-time megatestdbpath )))
	    (if (> modtime last-db-update)