Overview
Context
Changes
Modified dashboard-tests.scm
from [0e4c7cba39]
to [9acf57a172].
| ︙ | | |
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
|
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
|
-
+
|
(string<? (conc time-a)(conc time-b)))))))))
;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
(let* ((db-path (conc *toppath* "db/main.db"))
(db (make-dbr:dbstruct path: *toppath*))
(db (make-dbr:dbstruct path: *toppath* local: #t))
(tdb (tdb:open-test-db-by-test-id-local test-id))
(testdat (db:get-test-info-by-id db test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
(if (not testdat)
(begin
|
| ︙ | | |
Modified dashboard.scm
from [a979414615]
to [093ab7bea8].
| ︙ | | |
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
-
+
|
(exit)))
(if (not (setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *db* (make-dbr:dbstruct path: *toppath*))
(define *db* (make-dbr:dbstruct path: *toppath* local: #t))
;; (define sdb:qry (make-sdb:qry)) ;; 'init #f)
;; (if (args:get-arg "-host")
;; (begin
;; (set! *runremote* (string-split (args:get-arg "-host" ":")))
;; (client:launch))
|
| ︙ | | |
Modified db.scm
from [805085a1e2]
to [95e2197f8b].
| ︙ | | |
96
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
|
96
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
|
+
-
+
-
+
-
-
-
-
+
+
+
+
+
+
+
|
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((rdb (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(if rdb
rdb
(let* ((local (dbr:dbstruct-get-local dbstruct))
(let* ((toppath (dbr:dbstruct-get-path dbstruct))
(toppath (dbr:dbstruct-get-path dbstruct))
(dbpath (conc toppath "/db/" run-id ".db"))
(dbexists (file-exists? dbpath))
(inmem (open-inmem-db))
(inmem (if local #f (open-inmem-db)))
(db (sqlite3:open-database dbpath))
(write-access (file-write-access? dbpath))
(handler (make-busy-timeout 136000)))
(if (and dbexists (not write-access))
(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
(if write-access
(begin
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)(db:initialize-run-id-db db run-id))
(dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db)
(dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem)
(dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t)
(db:sync-tables db:sync-tests-only db inmem)
inmem))))
(dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t)
(if local
db
(begin
(dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem)
(db:sync-tables db:sync-tests-only db inmem)
inmem))))))
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((mdb (dbr:dbstruct-get-main dbstruct)))
(if mdb
mdb
|
| ︙ | | |
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
-
+
+
+
-
-
-
+
+
+
+
-
|
(if (> mtime stime)
(begin
(db:sync-tables db:sync-tests-only inmem rundb)
(vector-set! runvec (dbr:dbstruct-field-name->run 'stime (current-milliseconds)))))))
(hash-table-values (vector-ref dbstruct 1))))
;; close all opened run-id dbs
(define (db:close-all-db)
(define (db:close-all dbstruct)
;; finalize main.db
(sqlite3:finalize! (db:get-db dbstruct #f))
(for-each
(lambda (db)
(finalize! db))
(hash-table-values (vector-ref *open-dbs* 1)))
(lambda (runvec)
(let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))))
(sqlite3:finalize! rundb)))
(hash-table-values (vector-ref dbstruct 1))))
(finalize! (vector-ref *open-dbs* 0)))
|
| ︙ | | |
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
395
396
397
398
399
400
401
402
403
|
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
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
-
-
-
-
-
+
+
+
+
+
-
+
-
-
-
+
+
+
|
(db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(if (or *db-write-access*
(not (member proc *db:all-write-procs*)))
(let* ((db (cond
((sqlite3:database? idb) idb)
((not idb) (make-dbr:dbstruct path: *toppath*))
((procedure? idb) (idb))
(else (make-dbr:dbstruct path: *toppath*))))
(let* ((db (cond
((sqlite3:database? idb) idb)
((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
(else (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! db))
(if (not idb)(sqlite3:finalize! dbstruct))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
(begin
(debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 " " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain)
(thread-sleep! (random 120))
(debug:print-info 0 "trying db call one more time....")
(apply open-run-close-no-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
(define open-run-close (if (debug:debug-mode 2)
open-run-close-no-exception-handling
open-run-close-exception-handling))
(define open-run-close ;; (if (debug:debug-mode 2)
open-run-close-no-exception-handling)
;; open-run-close-exception-handling))
(define (db:initialize-megatest-db db)
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys)))
|
| ︙ | | |
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
|
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
|
-
-
-
+
+
+
+
|
res))
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs db runpatt count offset keypatts)
(let* ((res '())
(keys (db:get-keys db))
(define (db:get-runs dbstruct runpatt count offset keypatts)
(let* ((db (db:get-db dbstruct #f))
(res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
|
| ︙ | | |
Modified db_records.scm
from [76bc6ba447]
to [312e31a234].
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
|
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
|
-
+
-
+
+
|
;;======================================================================
;; dbstruct
;;======================================================================
;;
;; -path-|-megatest.db
;; |-db-|-main.db
;; |-monitor.db
;; |-sdb.db
;; |-fdb.db
;; |-1.db
;; |-<N>.db
(define (make-dbr:dbstruct #!key (path #f))
(define (make-dbr:dbstruct #!key (path #f)(local #f))
(vector
#f ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM
(make-hash-table) ;; run-id => [ rundb inmemdb last-mod last-read last-sync ]
#f ;; the global string db (use for state, status etc.)
path)) ;; path to database files/megatest area
path ;; path to database files/megatest area
local)) ;; read-only local access
;; get and set main db
(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))
;; get a rundb vector
(define (dbr:dbstruct-get-rundb-rec vec run-id)
|
| ︙ | | |
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
+
+
+
-
+
+
|
(vector-set! runvec 1 inmemdb)))
;; the string db
(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2))
(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db))
;; path
(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3))
;; local
(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4))
(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val))
(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id vec) (vector-ref vec 1))
(define-inline (db:test-get-testname vec) (vector-ref vec 2))
(define-inline (db:test-get-state vec) (vector-ref vec 3))
|
| ︙ | | |
Modified megatest.scm
from [a031866854]
to [38bd73f0db].
| ︙ | | |
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
|
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
|
-
+
-
+
-
+
-
+
|
;;======================================================================
;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
(if (setup-for-run)
(let* ((db (make-dbr:dbstruct path: *toppath* local: #t))
(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(runpatt (args:get-arg "-list-runs"))
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(runsdat (db:get-runs db runpatt #f #f '()))
(runsdat (db:get-runs dbstruct runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (db:get-keys db))
(keys (db:get-keys dbstruct))
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table)))
;; Each run
(for-each
(lambda (run)
(let ((targetstr (string-intersperse (map (lambda (x)
(db:get-value-by-header run header x))
keys) "/")))
(if db-targets
(if (not (hash-table-ref/default seen targetstr #f))
(begin
(hash-table-set! seen targetstr #t)
;; (print "[" targetstr "]"))))
(print targetstr))))
(if (not db-targets)
(let* ((run-id (db:get-value-by-header run header "id"))
(tests (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
(tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
(print "Run: " targetstr "/" (db:get-value-by-header run header "runname")
" status: " (db:get-value-by-header run header "state")
" run-id: " run-id ", number tests: " (length tests))
(for-each
(lambda (test)
(format #t
" Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
|
| ︙ | | |
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
|
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
|
-
+
+
-
+
|
(print " cpuload: " (db:test-get-cpuload test)
"\n diskfree: " (db:test-get-diskfree test)
"\n uname: " (sdb:qry 'getstr (db:test-get-uname test))
"\n rundir: " (filedb:get-path *fdb* (db:test-get-rundir test))
)
;; Each test
;; DO NOT remote run
(let ((steps (db:get-steps-for-test db (db:test-get-id test))))
(let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
(tdb:step-get-stepname step)
(tdb:step-get-state step)
(tdb:step-get-status step)
(tdb:step-get-event_time step)))
steps)))))
tests)))))
runs)
(db:close-all dbstruct)
(set! *didsomething* #t))))
(set! *didsomething* #t))))
;;======================================================================
;; full run
;;======================================================================
;; get lock in db for full run for this directory
;; for all tests with deps
|
| ︙ | | |
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
|
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
|
-
+
-
+
-
+
-
+
-
-
+
+
|
;; (if (sqlite3:database? db)(sqlite3:finalize! db))
)
;; else do a general-run-call
(general-run-call
"-test-paths"
"Get paths to tests"
(lambda (target runname keys keyvals)
(let* ((db (make-dbr:dbstruct path: *toppath* local: #t))
(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
;; DO NOT run remote
(paths (db:test-get-paths-matching db keys target)))
(paths (db:test-get-paths-matching dbstruct keys target)))
(for-each (lambda (path)
(print path))
paths)
(sqlite3:finalize! db))))))
(db:close-all dbstruct))))))
;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================
(if (args:get-arg "-extract-ods")
(general-run-call
"-extract-ods"
"Make ods spreadsheet"
(lambda (target runname keys keyvals)
(let ((db (make-dbr:dbstruct path: *toppath* local: #t))
(let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(outputfile (args:get-arg "-extract-ods"))
(runspatt (args:get-arg ":runname"))
(pathmod (args:get-arg "-pathmod")))
;; (keyvalalist (keys->alist keys "%")))
(debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
(db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod)
(sqlite3:finalize! db)
(db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
(db:close-all dbstruct)
(set! *didsomething* #t)))))
;;======================================================================
;; execute the test
;; - gets called on remote host
;; - receives info from the -execute param
;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
|
| ︙ | | |
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
|
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
|
-
-
+
+
-
+
-
+
+
+
+
-
+
-
+
+
|
;;======================================================================
;; Start a repl
;;======================================================================
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (setup-for-run))
(db (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(if db
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(if dbstruct
(begin
(set! *db* db)
(set! *db* dbstruct)
(set! *client-non-blocking-mode* #t)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load"))))
(load (args:get-arg "-load")))
(db:close-all dbstruct))
(exit))
(set! *didsomething* #t)))
;; Not converted to use dbstruct yet
;;
(if (args:get-arg "-convert-to-norm")
(let* ((toppath (setup-for-run))
(db (if toppath (make-dbr:dbstruct path: toppath local: #t))))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
(for-each
(lambda (field)
(let ((dat '()))
(debug:print-info 0 "Getting data for field " field)
(sqlite3:for-each-row
(lambda (id val)
(set! dat (cons (list id val) dat)))
db
(get-db db run-id)
(conc "SELECT id," field " FROM tests;"))
(debug:print-info 0 "found " (length dat) " items for field " field)
(let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
(for-each
(lambda (item)
(let ((newval (sdb:qry 'getid (cadr item))))
(if (not (equal? newval (cadr item)))
(debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item)))
(sqlite3:execute qry newval (car item))))
dat)
(sqlite3:finalize! qry))))
(db:close-all dbstruct)
(list "uname" "rundir" "final_logf" "comment"))
(set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
;;======================================================================
|
| ︙ | | |