Overview
Context
Changes
Modified common.scm
from [dca7be54b5]
to [4045fa5b1b].
| ︙ | | |
347
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
|
347
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
|
-
-
-
-
+
+
+
+
-
-
-
-
+
+
+
+
+
-
+
|
(delete-file* fname))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
'((0 "RUNNING")
(1 "COMPLETED")
(2 "REMOTEHOSTSTART")
(3 "LAUNCHED")
'((0 "ARCHIVED")
(1 "STUCK")
(2 "KILLREQ")
(3 "KILLED")
(4 "NOT_STARTED")
(5 "KILLED")
(6 "KILLREQ")
(7 "STUCK")
(8 "ARCHIVED")))
(5 "RUNNING")
(6 "LAUNCHED")
(7 "REMOTEHOSTSTART")
(8 "COMPLETED")
))
(define *common:std-statuses*
'((0 "DELETED")
'(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "CHECK")
(4 "SKIP")
(5 "WARN")
(6 "WAIVED")
(7 "STUCK/DEAD")
|
| ︙ | | |
Modified dashboard-tests.scm
from [256e137ebb]
to [2bf309096b].
| ︙ | | |
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
|
-
+
+
|
(apply iup:hbox
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(rmt:test-set-state-status-by-id run-id test-id state #f #f)
;; (rmt:test-set-state-status-by-id run-id test-id state #f #f)
(rmt:roll-up-pass-fail-counts run-id test-id #f state #f) ;; test-name passed in as test-id is respected
(db:test-set-state! testdat state)))))
btn))
(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
(for-each
(lambda (btn)
|
| ︙ | | |
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
|
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
|
-
+
+
|
(if wtxtbox
(begin
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
(rmt:test-set-state-status-by-id run-id test-id #f status #f)
;; (rmt:test-set-state-status-by-id run-id test-id #f status #f)
(rmt:roll-up-pass-fail-counts run-id test-id #f #f status) ;; test-name passed in as test-id is respected
(db:test-set-status! testdat status))))))))
btn))
(map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
|
| ︙ | | |
Modified db.scm
from [f1fd1d7a39]
to [eb86be463d].
| ︙ | | |
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
|
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
|
+
+
-
+
+
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(db:general-call dbdat 'state-status-msg (list state status msg test-id))
(db:general-call dbdat 'state-status (list state status test-id)))
(mt:process-triggers run-id test-id state status)))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed states
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:roll-up-items-state-status dbstruct run-id test-name item-path state status)
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status #!key (comment #f))
(let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct)))
(testdat1 (if (number? test-name)
(testdat (db:get-test-info dbstruct run-id test-name ""))
(test-id (db:test-get-id testdat)))
(db:get-test-info-by-id dbstruct run-id test-name)
#f))
(orig-test-id (db:test-get-id testdat1)) ;; the item
(test-name (db:test-get-testname testdat1))
(testdat (db:get-test-info dbstruct run-id test-name ""))
(test-id (db:test-get-id testdat))
(item-path (db:test-get-item-path testdat1)))
(sqlite3:with-transaction
db
(lambda ()
(db:test-set-state-status-by-id dbstruct run-id orig-test-id state status comment)
(if (not (equal? item-path "")) ;; only roll up IF we are an item
(let* ((all-curr-states (common:special-sort
(cons state (db:get-all-item-states db run-id test-name))
*common:std-states* >))
(all-curr-statuses (common:special-sort
(let ((statuses (db:get-all-item-statuses db run-id test-name)))
(if (equal? state "COMPLETED")
(cons status statuses)
statuses))
*common:std-statuses* >))
(newstate (if (null? all-curr-states) "NOT_STARTED" (car all-curr-states)))
(newstatus (if (null? all-curr-statuses) "n/a" (car all-curr-statuses))))
(db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus #f))))))
(define db:roll-up-pass-fail-counts db:roll-up-items-state-status)
(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)
;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update
;; (let* ((dbdat (db:get-db dbstruct run-id))
;; (toptestdat (db:get-test-info dbstruct run-id test-name item-path))
|
| ︙ | | |
Modified launch.scm
from [53f264e03f]
to [3949e4b80f].
| ︙ | | |
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
-
+
|
;; (run-n-wait fullrunscript)))
;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
;; Since we should have a clean slate at this time there is no need to do
;; any of the other stuff that tests:test-set-status! does. Let's just
;; force RUNNING/n/a
;; (thread-sleep! 0.3)
(tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
(rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING")
;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
(rmt:test-set-top-process-pid run-id test-id pid)
|
| ︙ | | |
Modified tests.scm
from [8d5f3a1ead]
to [0b8f9dada1].
| ︙ | | |
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
|
+
|
(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:roll-up-pass-fail-counts run-id test-name item
(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))
|
| ︙ | | |