Overview
Context
Changes
Modified api.scm
from [a1062addd1]
to [41b5b06e44].
| ︙ | | |
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
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
|
-
+
+
+
+
+
-
+
|
((delete-test-records) (apply db:delete-test-records db params))
((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db))
((test-set-status-state) (apply db:test-set-status-state db params))
((get-previous-test-run-record) (apply db:get-previous-test-run-record db params))
((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params)))
((db:test-get-logfile-info) (apply db:test-get-logfile-info db params))
((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params)))
((get-testinfo-state-status) (apply db:get-testinfo-state-status db params))
((get-testinfo-state-status) (let ((res (apply db:get-testinfo-state-status db params)))
(if (vector? res)
(vector->list res)
res)))
((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new db params))
((get-prereqs-not-met) (let ((res (apply db:get-prereqs-not-met db params)))
(map (lambda (x)
(if (vector? x)
(vector->list x)
x))
res)))
((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts db params))
|
| ︙ | | |
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
+
|
((update-run-event_time) (apply db:update-run-event_time db params))
;; MISC
((login) (apply db:login db params))
((general-call) (let ((stmtname (car params))
(realparams (cdr params)))
(db:general-call db stmtname realparams)))
((sync-inmem->db) (db:sync-back))
((kill-server)
(db:sync-to *inmemdb* *db*)
(let ((hostname (car *runremote*))
(port (cadr *runremote*))
(pid (if (null? params) #f (car params)))
(th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
(debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
|
| ︙ | | |
Modified dashboard-tests.scm
from [972ae80d2f]
to [d29ac1e9dd].
| ︙ | | |
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
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
|
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
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
|
-
+
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+
+
-
+
-
-
+
+
-
+
-
+
-
+
-
-
-
-
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
-
-
-
+
+
+
|
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 "step=" step)
(let ((record (hash-table-ref/default
res
(db:step-get-stepname step)
(tdb:step-get-stepname step)
;; stepname start end status Duration Logfile
(vector (db:step-get-stepname step) "" "" "" "" ""))))
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
(debug:print 6 "record(before) = " record
"\nid: " (db:step-get-id step)
"\nstepname: " (db:step-get-stepname step)
"\nstate: " (db:step-get-state step)
"\nstatus: " (db:step-get-status step)
"\ntime: " (db:step-get-event_time step))
(case (string->symbol (db:step-get-state step))
((start)(vector-set! record 1 (db:step-get-event_time step))
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(db:step-get-status step)))
(if (> (string-length (db:step-get-logfile step))
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (db:step-get-logfile step))))
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (db:step-get-event_time step)))
(vector-set! record 3 (db:step-get-status step))
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (db:step-get-status step))
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (db:step-get-logfile step))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (db:step-get-logfile step))))
(vector-set! record 5 (tdb:step-get-logfile step))))
(else
(vector-set! record 2 (db:step-get-state step))
(vector-set! record 3 (db:step-get-status step))
(vector-set! record 4 (db:step-get-event_time step))))
(hash-table-set! res (db:step-get-stepname step) record)
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 "record(after) = " record
"\nid: " (db:step-get-id step)
"\nstepname: " (db:step-get-stepname step)
"\nstate: " (db:step-get-state step)
"\nstatus: " (db:step-get-status step)
"\ntime: " (db:step-get-event_time step))))
;; (else (vector-set! record 1 (db:step-get-event_time step)))
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
((eq? (db:step-get-event_time a)(db:step-get-event_time b))
(< (db:step-get-id a) (db:step-get-id b)))
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
(define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f))
(if (or (not work-area)
(file-exists? (conc work-area "/testdat.db")))
(let* ((steps-data (tdb:get-steps-for-test test-id work-area))
|
| ︙ | | |
Modified dashboard.scm
from [b4efde3b5b]
to [b8686db61f].
| ︙ | | |
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
|
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
|
-
+
|
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
(> modtime last-db-update-time)
(> (current-seconds)(+ last-db-update-time 1)))))
(define *monitor-db-path* (conc *toppath* "/monitor.db"))
(define *monitor-db-path* (conc *toppath* "/db/monitor.db"))
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
(sqlite3:finalize! db))
(define (dashboard:run-update x)
|
| ︙ | | |
Modified db.scm
from [5380b387e8]
to [32892c2413].
| ︙ | | |
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
-
+
|
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
(exit))))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(dbexists (file-exists? dbpath))
(write-access (file-write-access? dbpath))
|
| ︙ | | |
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
-
-
+
+
+
+
+
+
|
(let* ((path (configf:lookup *configdat* "setup" "tmpdb"))
(fname (if path (conc path "/temp-megatest.db") #f))
(exists (and path (file-exists? fname)))
(db (if path
(begin
(create-directory path #t)
(sqlite3:open-database fname))
(sqlite3:open-database ":memory:"))))
(if (not exists) (db:initialize db))
(sqlite3:open-database ":memory:")))
(handler (make-busy-timeout 3600)))
(if (or (not path)
(not exists))
(db:initialize db))
(sqlite3:set-busy-handler! db handler)
db))
(define (db:sync-to fromdb todb)
;; strategy
;; 1. Get all run-ids
;; 2. For each run-id
;; a. Sync that run in a transaction
|
| ︙ | | |
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
|
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
|
-
+
-
-
-
-
-
+
-
-
-
-
-
-
-
+
|
(lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
db
qry
)
res))
(define (db:delete-test-records db tdb test-id #!key (force #f))
(define (db:delete-test-records db test-id)
(if tdb
(begin
(sqlite3:execute tdb "DELETE FROM test_steps;")
(sqlite3:execute tdb "DELETE FROM test_data;"))
(tdb:delete-test-step-records db test-id))
(if db
(begin
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
(sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id)
(if force
(sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))))
|
| ︙ | | |
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
|
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
|
+
+
+
+
+
+
+
+
+
+
+
|
;; (define (cdb:remote-run proc db . params)
;; (if (or *db-write-access*
;; (not (member proc *db:all-write-procs*)))
;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)
;; (begin
;; (debug:print 0 "ERROR: Attempt to access read-only database")
;; #f)))
(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
(if (and (not (equal? item-path ""))
(member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
(begin
(db:general-call 'update-pass-fail-counts db (list run-id test-name run-id test-name))
(if (equal? status "RUNNING")
(db:general-call 'top-test-set-running db (list run-id test-name))
(db:general-call 'top-test-set-per-pf-counts db (list run-id test-name run-id test-name)))
#f)
#f))
(define (db:test-get-logfile-info db run-id test-name)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
(set! logf final_logf)
(set! res (list path final_logf))
|
| ︙ | | |
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
|
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
|
-
+
|
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
|
| ︙ | | |
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
|
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
|
-
+
|
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
|
| ︙ | | |
Modified ezsteps.scm
from [5bdb7484d4]
to [a48b4294d3].
| ︙ | | |
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
-
+
|
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
(db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir))
(if logpro-used
(cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
(rmt:test-set-log! test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
(overall-status (cond
((eq? rollup-status 2) 'warn)
|
| ︙ | | |
Modified http-transport.scm
from [1dff27fc16]
to [a6b93a7de2].
| ︙ | | |
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
-
+
|
;; hostn))
(db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (if (and (args:get-arg "-port")
(string->number (args:get-arg "-port")))
(string->number (args:get-arg "-port"))
(if (and (config-lookup *configdat* "server" "port")
(string->number (config-lookup *configdat* "server" "port")))
(string->number (config-lookup *configdat* "server" "port"))
(+ 5000 (random 1001)))))
|
| ︙ | | |
Modified launch.scm
from [3c59fa35f3]
to [f885a90fba].
| ︙ | | |
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
-
+
|
(set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
(set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
;; open-run-close not needed for test-set-meta-info
(tests:set-full-meta-info #f test-id run-id 0 work-area)
(tests:set-full-meta-info test-id run-id 0 work-area)
;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
(tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a")
(thread-sleep! 0.3) ;; NFS slowness has caused grief here
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
|
| ︙ | | |
Modified megatest.scm
from [85bb5af86b]
to [aeda34eef4].
| ︙ | | |
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
|
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
|
-
+
|
(conc "(" (db:test-get-item-path test) ")")))
(db:test-get-state test)
(db:test-get-status test)
(db:test-get-run_duration test)
(db:test-get-event_time test)
(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-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)
)
|
| ︙ | | |
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
|
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
|
-
+
|
;; (set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
;; DO NOT remote run, makes calls to the testdat.db test db.
(db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)
(tdb:teststep-set-status! test-id step state status msg logfile work-area: work-area)
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
(exit 6))))))
(if (args:get-arg "-step")
(begin
(megatest:step
|
| ︙ | | |
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
|
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
|
-
+
-
+
|
(change-directory work-area)
;; can setup as client for server mode now
;; (client:setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either cdb:remote-run or open-run-close
(db:load-test-data db test-id work-area: work-area))
(tdb:load-test-data test-id work-area: work-area))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
(cdb:test-set-log! *runremote* test-id logfname)))
(rmt:test-set-log! test-id logfname)))
(if (args:get-arg "-set-toplog")
;; DO NOT run remote
(tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
(if (args:get-arg "-summarize-items")
;; DO NOT run remote
(tests:summarize-items db run-id test-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
|
| ︙ | | |
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
|
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
|
-
+
-
+
-
+
|
((zsh bash sh ash) "2>&1 >")
(else ">&")))
(fullcmd (conc "(" (string-intersperse
(cons cmd params) " ")
") " redir " " logfile)))
;; mark the start of the test
;; DO NOT run remote
(db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area)
(tdb:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area)
;; run the test step
(debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
(change-directory startingdir)
(set! exitstat (system fullcmd)) ;; cmd params))
(set! *globalexitstatus* exitstat)
;; (change-directory testpath)
;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
(if logprofile
(let* ((htmllogfile (conc stepname ".html"))
(oldexitstat exitstat)
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
(debug:print-info 2 "running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
(cdb:test-set-log! *runremote* test-id htmllogfile)))
(rmt:test-set-log! test-id htmllogfile)))
(let ((msg (args:get-arg "-m")))
;; DO NOT run remote
(db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area))
(tdb:teststep-set-status! test-id stepname "end" exitstat msg logfile work-area: work-area))
)))
(if (or (args:get-arg "-test-status")
(args:get-arg "-set-values"))
(let ((newstatus (cond
((number? status) (if (equal? status 0) "PASS" "FAIL"))
((and (string? status)
(string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
|
| ︙ | | |
Modified rmt.scm
from [277a7a3b51]
to [00b9d433cf].
| ︙ | | |
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
+
+
+
|
(define (rmt:kill-server)
(rmt:send-receive 'kill-server '()))
;; hand off a call to one of the db:queries statements
(define (rmt:general-call stmtname . params)
(rmt:send-receive 'general-call (append (list stmtname) params)))
(define (rmt:sync-inmem->db)
(rmt:send-receive 'sync-inmem->db '()))
;;======================================================================
;; K E Y S
;;======================================================================
(define (rmt:get-key-val-pairs run-id)
(rmt:send-receive 'get-key-val-pairs (list run-id)))
|
| ︙ | | |
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
-
+
-
+
+
+
+
|
(define (rmt:get-previous-test-run-record run-id test-name item-path)
(rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
(map list->vector
(rmt:send-receive 'get-matching-previous-test-run-records (list run-id test-name item-path))))
(define (rmt:db:test-get-logfile-info run-id test-name)
(define (rmt:test-get-logfile-info run-id test-name)
(rmt:send-receive 'test-get-logfile-info (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name)
(rmt:send-receive 'test-get-records-for-index-file (list run-id test-name)))
(define (rmt:get-testinfo-state-status test-id)
(rmt:send-receive 'get-testinfo-state-status (list test-id)))
(let ((res (rmt:send-receive 'get-testinfo-state-status (list test-id))))
(if (list? res)
(list->vector res)
res)))
(define (rmt:test-set-log! test-id logf)
(if (string? logf)(rmt:general-call 'test-set-log logf test-id)))
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname)))
|
| ︙ | | |
Modified tasks.scm
from [9517782d04]
to [c9fadd13bc].
| ︙ | | |
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
|
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
|
-
+
|
(sqlite3:execute mdb (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))
;;
(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 "Not starting monitor, already have more than two running")
(let* ((megatestdb (conc *toppath* "/megatest.db"))
(monitordbf (conc *toppath* "/monitor.db"))
(monitordbf (conc *toppath* "/db/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)
|
| ︙ | | |
Modified tests/Makefile
from [e01d7d9755]
to [ad942b6696].
1
2
3
4
5
6
7
8
9
10
11
12
|
1
2
3
4
5
6
7
8
9
10
11
12
13
|
+
|
#
# run some tests
BINPATH=$(shell readlink -m $(PWD)/../bin)
MEGATEST=$(BINPATH)/megatest
DASHBOARD=$(BINPATH)/dashboard
PATH := $(BINPATH):$(PATH)
RUNNAME := $(shell date +w%V.%u.%H.%M)
IPADDR := "-"
# Set SERVER to "-server -"
SERVER =
DEBUG = 1
LOGGING =
|
| ︙ | | |
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
|
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
157
|
-
+
-
+
-
+
-
+
-
+
-
-
+
+
-
+
|
# Some simple checks for bootstrapping and run loop logic
test9 : minsetup test9a test9b test9c test9d test9e
test9a :
@echo Run super-simple mintest e, no waitons.
cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
cd mintest;$(MEGATEST) -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9b :
@echo Run simple mintest d with one waiton c
cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
cd mintest;$(MEGATEST) -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9c :
@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
cd mintest;$(MEGATEST) -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9d :
@echo Run an itemized test with no items
cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
cd mintest;$(MEGATEST) -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9e :
@echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1
cd mintest;megatest -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
cd mintest;$(MEGATEST) -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test10 :
@echo Run a bunch of different targets simultaneously
(cd fullrun;$(MEGATEST) -server - ;sleep 2)&
for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \
(cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done
for sys in ubuntu suse redhat debian;do \
for fs in afs nfs zfs; do \
for dpath in none tmp; do \
(cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\
done;done;done
test11 :
cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; )
minsetup :
cd ..;make && make install
mkdir -p mintest/runs mintest/links
cd mintest;megatest -stop-server 0
cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log &
cd mintest;$(MEGATEST) -stop-server 0
cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log &
sleep 3
cd mintest;dashboard -rows 18 &
cd mintest;$(DASHBOARD) -rows 18 &
cleanprep : ../*.scm Makefile */*.config
mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links
cd ..;make;make install
rm -f */logging.db
touch cleanprep
|
| ︙ | | |
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
-
+
-
+
|
cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath %
clean :
rm cleanprep
kill :
killall -v mtest main.sh dboard || true
rm -f */megatest.db */logging.db */monitor.db || true
rm -rf */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* || true
killall -v mtest dboard || true
hardkill : kill
sleep 5;killall -v mtest main.sh dboard -9
sleep 2;killall -v mtest main.sh dboard -9
listservers :
cd fullrun;$(MEGATEST) -list-servers
runforever :
while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done
|
Modified tests/mintest/megatest.config
from [24752ab48d]
to [158955d103].
1
2
3
4
5
6
7
8
9
10
11
12
13
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
+
|
[fields]
X TEXT
[setup]
max_concurrent_jobs 50
linktree #{getenv PWD}/linktree
transport http
[server]
port 8090
[jobtools]
useshell yes
launcher nbfind
|
| ︙ | | |
Modified tests/rununittest.sh
from [4e5a87c2e6]
to [45ac8d74ef].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
-
+
-
+
|
#!/bin/bash
# Usage: rununittest.sh testname debuglevel
#
# Clean setup
#
rm -f simplerun/megatest.db
rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db
rm -rf simplelinks/ simpleruns/
mkdir -p simplelinks simpleruns
(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm)
# Run the test $1 is the unit test to run
cd simplerun;echo '(load "../tests.scm")' | megatest -repl -debug $2 $1
cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1
|
Added tests/unittests/inmemdb.scm version [89b5b8b964].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; S E R V E R
;;======================================================================
;; Run like this:
;;
;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
(set! *transport-type* 'http)
(system "cp ../fullrun/megatest.db megatest.db")
(test "open inmem db" 1 (begin (open-in-mem-db) 1))
(test "setup for run" #t (begin (setup-for-run)
(string? (getenv "MT_RUN_AREA_HOME"))))
(system "megatest -server - -debug 0 &")
(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
(define *keys* (keys:config-get-fields *configdat*))
(define *keyvals* (keys:target->keyval *keys* "a/b/c"))
(test #f #t (string? (car *runremote*)))
(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
(define inmem (open-in-mem-db))
(define (inmem-test t b)
(test "inmem sync to" t (db:sync-to *db* inmem))
(test "inmem sync back" b (db:sync-to inmem *db*)))
(inmem-test 0 0)
(inmem-test 1 1)
;;======================================================================
;; D B
;;======================================================================
(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
Modified tests/unittests/server.scm
from [2057de46b9]
to [4b5ecf2866].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
-
-
-
+
+
-
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
-
-
-
-
+
+
|
;;======================================================================
;; S E R V E R
;;======================================================================
;; Run like this:
;;
;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
(set! *transport-type* 'http)
(test "open inmem db" 1 (begin (open-in-mem-db) 1))
(system "megatest -server - -debug 0 &")
(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
(let loop ((n 10))
(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
(thread-sleep! 1) ;; need to wait for server to start.
(let ((res (open-run-close tasks:get-best-server tasks:open-db)))
(print "tasks:get-best-server returned " res)
(if (and (not res)
(> n 0))
(loop (- n 1)))))
(test "get-best-server" #t (begin
(client:launch)
(let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
(vector? dat))))
(define *keys* (keys:config-get-fields *configdat*))
(define *keyvals* (keys:target->keyval *keys* "a/b/c"))
(test #f #t (string? (car *runremote*)))
(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
(define inmem (open-in-mem-db))
(define (inmem-test t b)
(test "inmem sync to" t (db:sync-to *db* inmem))
(test "inmem sync back" b (db:sync-to inmem *db*)))
(inmem-test 0 0)
(test "sync back" #t (> (rmt:sync-inmem->db) 0))
(inmem-test 1 1)
(inmem-test 1 1)
(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
;;======================================================================
;; D B
;;======================================================================
(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
|