Overview
Context
Changes
Modified dashboard-tests.scm
from [b8df1f8819]
to [6bf2b48df2].
| ︙ | | |
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
|
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
|
-
+
|
(debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
(open-run-close db:get-test-info-by-id db test-id )))))
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (db:get-compressed-steps test-id work-area: rundir))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(set! rundir (db:test-get-rundir testdat))
(set! rundir (sdb:qry 'getstr (db:test-get-rundir testdat)))
(set! testfullname (db:test-get-fullname testdat))
;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
(if (eq? curr-mod-time db-mod-time) ;; do only once if same
(set! db-mod-time (+ curr-mod-time 1))
(set! db-mod-time curr-mod-time))
(set! last-update (current-milliseconds))
(set! request-update #f) ;; met the need ...
|
| ︙ | | |
Modified db.scm
from [3b70f7465f]
to [b08cbf488a].
| ︙ | | |
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
|
-
+
|
(debug:print-info 11 "open-test-db END (unsucessful)" work-area)
#f)))
;; find and open the testdat.db file for an existing test
(define (db:open-test-db-by-test-id db test-id #!key (work-area #f))
(let* ((test-path (if work-area
work-area
(cdb:remote-run db:test-get-rundir-from-test-id db test-id))))
(sdb:qry 'getstr (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))))
(debug:print 3 "TEST PATH: " test-path)
(open-test-db test-path)))
(define (db:testdb-initialize db)
(debug:print 11 "db:testdb-initialize START")
(for-each
(lambda (sqlcmd)
|
| ︙ | | |
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
|
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
|
-
-
+
+
-
-
+
+
|
(define (db:test-set-comment db test-id comment)
(sqlite3:execute
db
"UPDATE tests SET comment=? WHERE id=?;"
(sdb:qry 'getid comment) test-id))
(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
(cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))
(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir-id)
(cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir-id run-id test-name item-path))
(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)
(cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))
(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir-id)
(cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir-id test-id))
(define (db:test-get-rundir-from-test-id db test-id)
(let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f)))
;; (if res
;; res
;; (begin
(sqlite3:for-each-row
|
| ︙ | | |
Modified launch.scm
from [ae5ddfc81a]
to [b994a7eaec].
| ︙ | | |
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
+
|
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses sdb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
;;======================================================================
;; ezsteps
|
| ︙ | | |
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
|
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
|
-
+
-
+
-
+
|
(if rd rd (conc *toppath* "/runs"))))
(lnkbase (conc linktree "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))
;; Update the rundir path in the test record for all
(cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf)
(cdb:test-set-rundir-by-test-id *runremote* test-id (sdb:qry 'getid lnkpathf))
(debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
(debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
(create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
;; create the directory for the tests dir links, this is needed no matter what...
(if (and (not (directory-exists? lnkbase))
(not (file-exists? lnkbase)))
(create-directory lnkbase #t))
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
;; thousands of unnecessary updates, cache the fact it was set and don't set it
;; again.
;; NB - This is not working right - some top tests are not getting the path set!!!
(if (not (hash-table-ref/default *toptest-paths* testname #f))
(let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path))
(curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
(curr-test-path (if testinfo (sdb:qry 'getstr (db:test-get-rundir testinfo)) #f)))
(hash-table-set! *toptest-paths* testname curr-test-path)
;; NB// Was this for the test or for the parent in an iterated test?
(cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
(cdb:test-set-rundir! *runremote* run-id testname "" (sdb:qry 'getid lnkpath)) ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(create-directory toptest-path #t)
(hash-table-set! *toptest-paths* testname toptest-path)))))
|
| ︙ | | |
Modified megatest.scm
from [061ae615cf]
to [28774d006a].
| ︙ | | |
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
|
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
|
-
-
+
+
|
(db:test-get-host test))
(if (not (or (equal? (db:test-get-status test) "PASS")
(equal? (db:test-get-status test) "WARN")
(equal? (db:test-get-state test) "NOT_STARTED")))
(begin
(print " cpuload: " (db:test-get-cpuload test)
"\n diskfree: " (db:test-get-diskfree test)
"\n uname: " (db:test-get-uname test)
"\n rundir: " (db:test-get-rundir test)
"\n uname: " (sdb:qry 'getstr (db:test-get-uname test))
"\n rundir: " (sdb:qry 'getstr (db:test-get-rundir test))
)
;; Each test
;; DO NOT remote run
(let ((steps (db:get-steps-for-test #f (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
|
| ︙ | | |
Modified mt.scm
from [4beb856e75]
to [f901ea9aed].
| ︙ | | |
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
-
+
|
;;======================================================================
;; T R I G G E R S
;;======================================================================
(define (mt:process-triggers test-id newstate newstatus)
(let* ((test-dat (mt:lazy-get-test-info-by-id test-id))
(test-rundir (db:test-get-rundir test-dat))
(test-rundir (sdb:qry 'getstr (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))))
(if (and (file-exists? test-rundir)
(directory? test-rundir))
(begin
|
| ︙ | | |
Modified runs.scm
from [954fc2f4a3]
to [00b9e6b739].
| ︙ | | |
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
|
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
|
-
-
+
+
-
+
|
((print-run)
(debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
(debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
(else
(debug:print-info 0 "action not recognised " action)))
(let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))
(dirb (db:test-get-rundir b)))
(let ((sorted-tests (sort tests (lambda (a b)(let ((dira (sdb:qry 'getstr (db:test-get-rundir a)))
(dirb (sdb:qry 'getstr (db:test-get-rundir b))))
(if (and (string? dira)(string? dirb))
(> (string-length dira)(string-length dirb))
#f)))))
(test-retry-time (make-hash-table))
(allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em
(let loop ((test (car sorted-tests))
(tal (cdr sorted-tests)))
(let* ((test-id (db:test-get-id test))
(new-test-dat (cdb:get-test-info-by-id *runremote* test-id)))
(if (not new-test-dat)
(begin
(debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
(if (not (null? tal))
(loop (car tal)(cdr tal))))
(let* ((item-path (db:test-get-item-path new-test-dat))
(test-name (db:test-get-testname new-test-dat))
(run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree
(run-dir (sdb:qry 'getstr (db:test-get-rundir new-test-dat))) ;; run dir is from the link tree
(real-dir (if (file-exists? run-dir)
(resolve-pathname run-dir)
#f))
(test-state (db:test-get-state new-test-dat))
(test-fulln (db:test-get-fullname new-test-dat)))
(case action
((remove-runs)
|
| ︙ | | |
Modified tests.scm
from [ed985ac2fe]
to [fe20e13a60].
| ︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
+
|
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses sdb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
| ︙ | | |
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
-
-
+
+
|
(loop (car tal)(cdr tal))))))))))
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
(test-rundir (db:test-get-rundir testdat))
(prev-rundir (db:test-get-rundir prev-testdat))
(test-rundir (sdb:qry 'getstr (db:test-get-rundir testdat)))
(prev-rundir (sdb:qry 'getstr (db:test-get-rundir prev-testdat)))
(waivers (configf:section-vars testconfig "waivers"))
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
(logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
(if (not (file-exists? test-rundir))
(begin
(debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver")
|
| ︙ | | |