Modified Makefile
from [0820a667ed]
to [7f2dc43cfa].
| ︙ | | |
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
-
+
-
+
+
|
cgisetup/models/pgdb.scm
# server.scm http-transport.scm client.scm rmt.scm
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
configfmod.scm servermod.scm clientmod.scm rmtmod.scm \
artifacts.scm
artifacts.scm apimod.scm
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
# dbmod.import.o is just a hack here
mofiles/dbfile.o : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
mofiles/dbfile.o mofiles/clientmod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/servermod.o : mofiles/artifacts.o
mofiles/rmtmod.o : mofiles/apimod.o
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
|
| ︙ | | |
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
-
+
|
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
# tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
mofiles-made : $(MOFILES)
make $(MOIMPFILES)
megatest.o : mofiles-made megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)
|
| ︙ | | |
Modified api.scm
from [5d01bf138b]
to [fb1ad3313e].
| ︙ | | |
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
93
94
95
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(declare (unit api))
(declare (uses rmtmod))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(declare (uses debugprint))
(import dbmod)
(import dbfile)
(import rmtmod)
(import rmtmod
debugprint)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
get-keys
get-key-vals
test-toplevel-num-items
get-test-info-by-id
get-steps-info-by-id
get-data-info-by-id
test-get-rundir-from-test-id
get-count-tests-running-for-testname
get-count-tests-running
get-count-tests-running-in-jobgroup
get-previous-test-run-record
get-matching-previous-test-run-records
test-get-logfile-info
test-get-records-for-index-file
get-testinfo-state-status
test-get-top-process-pid
test-get-paths-matching-keynames-target-new
get-prereqs-not-met
get-count-tests-running-for-run-id
get-run-info
get-run-status
get-run-state
get-run-stats
get-run-times
get-targets
get-target
;; register-run
get-tests-tags
get-test-times
get-tests-for-run
get-tests-for-run-state-status
get-test-id
get-tests-for-runs-mindata
get-tests-for-run-mindata
get-run-name-from-id
get-runs
simple-get-runs
get-num-runs
get-runs-cnt-by-patt
get-all-run-ids
get-prev-run-ids
get-run-ids-matching-target
get-runs-by-patt
get-steps-data
get-steps-for-test
read-test-data
read-test-data-varpatt
login
tasks-get-last
testmeta-get-record
have-incompletes?
;; synchash-get
get-changed-record-ids
get-run-record-ids
get-not-completed-cnt))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
;; SERVERS
;; start-server
;; kill-server
;; TESTS
test-set-state-status-by-id
delete-test-records
delete-old-deleted-test-records
test-set-state-status
test-set-top-process-pid
set-state-status-and-roll-up-items
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
;; RUNS
register-run
set-tests-state-status
delete-run
lock/unlock-run
update-run-event_time
mark-incomplete
set-state-status-and-roll-up-run
;; STEPS
teststep-set-status!
delete-steps-for-test
;; TEST DATA
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
drop-all-triggers
create-all-triggers
update-tesdata-on-repilcate-db
;; TESTMETA
testmeta-add-record
testmeta-update-field
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
|
| ︙ | | |
Modified apimod.scm
from [a7cef484dc]
to [a87fc9869a].
| ︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
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
93
94
95
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
133
134
135
136
137
138
139
140
141
142
143
|
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit apimod))
(declare (uses commonmod))
(declare (uses ulex))
(import (prefix ulex ulex:))
|
Modified archive.scm
from [25e6383e3d]
to [7a56d0b0c3].
| ︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
+
+
+
|
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(import debugprint)
;;======================================================================
;;
;;======================================================================
;; NOT CURRENTLY USED
;;
|
| ︙ | | |
Name change
from client.scm
to attic/client.scm.
Name change
from http-transport.scm
to attic/http-transport.scm.
Name change
from mockup-cached-writes.scm
to attic/mockup-cached-writes.scm.
Name change
from monitor.scm
to attic/monitor.scm.
Name change
from rmtdb.scm
to attic/rmtdb.scm.
Name change
from server.scm
to attic/server.scm.
Name change
from synchash.scm
to attic/synchash.scm.
Name change
from task_records.scm
to attic/task_records.scm.
Modified clientmod.scm
from [dc86555194]
to [cfb1e9f3ec].
| ︙ | | |
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
|
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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
|
;;(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
;; message-digest matchable spiffy uri-common intarweb http-client
;; spiffy-request-vars uri-common intarweb directory-utils)
(declare (unit clientmod))
(declare (uses servermod))
(declare (uses artifacts))
(declare (uses debugprint))
(module clientmod
*
(import scheme
chicken
posix
data-structures
srfi-18
typed-records
artifacts
servermod
debugprint
)
(defstruct con ;; client connection
(hdir #f) ;; this is the directory sdir/serverhost.serverpid
(hdir #f)
(sdir #f)
(obj-to-str #f)
(str-to-obj #f)
(host #f)
(pid #f)
(sdat #f) ;; server artifact data
(areapath #f)
)
(define *my-client-signature* #f)
(define (client:find-server areapath)
(let* ((sdir (conc areapath"/.server"))
(sarfs (glob (conc sdir"/*.artifact")))) ;; server artifacts
(if (null? sarfs)
(begin
(server:launch areapath)
(thread-sleep! 1)
(client:find-server areapath))
(let* ((sarf (car sarfs))
(sdat (read-artifact->alist sarf))
(hdir (alist-ref 'd sdat)))
(make-con hdir: hdir sdat: sdat)))))
(make-con hdir: hdir sdir: sdir sdat: sdat)))))
;; move this into artifacts
;; find the artifact with key set to val
;;
(define (client:find-artifact arfs key val)
(let loop ((rem arfs))
(if (null? rem) ;; didn't find a match
#f
(let* ((arf (car rem))
(adat (read-artifact->alist arf))
(val-found (alist-ref key adat)))
(if (equal? val-found val)
(cons (cons 'path arf) adat) ;; return the artifact as alist anotated with 'path
(loop (cdr rem)))))))
(define (client:send-receive con cmd params)
(let* ((obj->string (con-obj-to-str con))
(string->obj (con-str-to-obj con))
(arf `((c . ,cmd)
(p . ,(obj->string params))
(h . ,(con-host con))
(i . ,(con-pid con))))
(h . ,(con-host con)) ;; tells server where to put response
(i . ,(con-pid con))));; and is where this client looks
(hdir (con-hdir con))
(sdir (con-sdir con))
(uuid (write-alist->artifact hdir arf ptype: 'Q)))
;; wait for a response here
(uuid (write-alist->artifact hdir arf ptype: 'Q))
(respdir (conc sdir"/"(con-host con)"."(con-pid con)"/responses")))
(let loop ((start (current-milliseconds)))
(let* ((arfs (glob (conc respdir"/*.artifact")))
(res (client:find-artifact arfs 'P uuid)))
(if res ;; we found our response!
(let ((arf (alist-ref 'path res))
(rstr (alist-ref 'r res)))
(delete-file arf) ;; done with it, future - move to archive area
(string->obj rstr))
(begin ;; no response yet, look again in 500ms
(thread-sleep! 0.5)
(loop (current-milliseconds))))))))
#f
))
|
Modified common.scm
from [c2a1a4f762]
to [edacec5a50].
| ︙ | | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
+
+
-
+
+
|
(prefix nanomsg nmsg:)
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
(declare (uses commonmod))
(declare (uses debugprint))
(import commonmod)
(import commonmod
debugprint)
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
|
| ︙ | | |
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
158
159
160
161
|
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
158
159
160
161
|
-
+
-
-
-
|
(define *db-keys* #f)
(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
|
| ︙ | | |
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
-
|
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
;; (define *no-sync-db* #f) ;; moved to dbfile
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
|
| ︙ | | |
Modified common_records.scm
from [80f9e14f2d]
to [fd319a6e15].
| ︙ | | |
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
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
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
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
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
(define-inline (with-mutex mtx accessor record . val)
(mutex-lock! mtx)
(let ((res (apply accessor record val)))
(mutex-unlock! mtx)
res))
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr)
(or (hash-table-ref/default *verbosity-cache* vstr #f)
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug:debug-mode n)
(cond
((and (number? *verbosity*) ;; number number
(number? n))
(<= n *verbosity*))
((and (list? *verbosity*) ;; list number
(number? n))
(member n *verbosity*))
((and (list? *verbosity*) ;; list list
(list? n))
(not (null? (lset-intersection! eq? *verbosity* n))))
((and (number? *verbosity*)
(list? n))
(member *verbosity* n))))
(define (debug:setup)
(let ((debugstr (or (args:get-arg "-debug")
(args:get-arg "-debug-noprop")
(getenv "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (and (not (args:get-arg "-debug-noprop"))
(or (args:get-arg "-debug")
(not (getenv "MT_DEBUG_MODE"))))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location "??"))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
(temp (string-split (->string this-loc) " "))
(this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
(let* ((color-on "\x1b[1m")
(color-off "\x1b[0m")
(dp-args
(append
(list 0 *default-log-port*
(conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
in-args)))
(apply debug:print dp-args))))
(define *BBpp_custom_expanders_list* (make-hash-table))
;; register hash tables with BBpp.
(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
(cons hash-table? hash-table->alist))
;; test name converter
(define (BBpp_custom_converter arg)
(let ((res #f))
(for-each
(lambda (custom-type-name)
(let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
(custom-type-test (car custom-type-info))
(custom-type-converter (cdr custom-type-info)))
(when (and (not res) (custom-type-test arg))
(set! res (custom-type-converter arg)))))
(hash-table-keys *BBpp_custom_expanders_list*))
(if res (BBpp_ res) arg)))
(define (BBpp_ arg)
(cond
;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
((hash-table? arg)
(let ((al (hash-table->alist arg)))
(BBpp_ (cons HASH_TABLE: al))))
((null? arg) '())
;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
(pp (BBpp_ arg)))
;; ;; this was cached based on results from profiling but it turned out the profiling
;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; ;; in for now but can probably take it out later.
;; ;;
;; (define (debug:calc-verbosity vstr)
;; (or (hash-table-ref/default *verbosity-cache* vstr #f)
;; (let ((res (cond
;; ((number? vstr) vstr)
;; ((not (string? vstr)) 1)
;; ;; ((string-match "^\\s*$" vstr) 1)
;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
;; (cond
;; ((> (length debugvals) 1) debugvals)
;; ((> (length debugvals) 0)(car debugvals))
;; (else 1))))
;; ((args:get-arg "-v") 2)
;; ((args:get-arg "-q") 0)
;; (else 1))))
;; (hash-table-set! *verbosity-cache* vstr res)
;; res)))
;;
;; ;; check verbosity, #t is ok
;; (define (debug:check-verbosity verbosity vstr)
;; (if (not (or (number? verbosity)
;; (list? verbosity)))
;; (begin
;; (print "ERROR: Invalid debug value \"" vstr "\"")
;; #f)
;; #t))
;;
;; (define (debug:debug-mode n)
;; (cond
;; ((and (number? *verbosity*) ;; number number
;; (number? n))
;; (<= n *verbosity*))
;; ((and (list? *verbosity*) ;; list number
;; (number? n))
;; (member n *verbosity*))
;; ((and (list? *verbosity*) ;; list list
;; (list? n))
;; (not (null? (lset-intersection! eq? *verbosity* n))))
;; ((and (number? *verbosity*)
;; (list? n))
;; (member *verbosity* n))))
;;
;; (define (debug:setup)
;; (let ((debugstr (or (args:get-arg "-debug")
;; (args:get-arg "-debug-noprop")
;; (getenv "MT_DEBUG_MODE"))))
;; (set! *verbosity* (debug:calc-verbosity debugstr))
;; (debug:check-verbosity *verbosity* debugstr)
;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
;; (if (not *verbosity*)(set! *verbosity* 1))
;; (if (and (not (args:get-arg "-debug-noprop"))
;; (or (args:get-arg "-debug")
;; (not (getenv "MT_DEBUG_MODE"))))
;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
;; (string-intersperse (map conc *verbosity*) ",")
;; (conc *verbosity*))))))
;;
;; (define (debug:print n e . params)
;; (if (debug:debug-mode n)
;; (with-output-to-port (or e (current-error-port))
;; (lambda ()
;; (if *logging*
;; (db:log-event (apply conc params))
;; (apply print params)
;; )))))
;;
;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;; (let* ((stack (get-call-chain))
;; (location "??"))
;; (for-each
;; (lambda (frame)
;; (let* ((this-loc (vector-ref frame 0))
;; (temp (string-split (->string this-loc) " "))
;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;; (if (equal? this-func "BB>")
;; (set! location this-loc))))
;; stack)
;; (let* ((color-on "\x1b[1m")
;; (color-off "\x1b[0m")
;; (dp-args
;; (append
;; (list 0 *default-log-port*
;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
;; in-args)))
;; (apply debug:print dp-args))))
;;
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;;
;;
;;
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;; (cons hash-table? hash-table->alist))
;;
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;; (let ((res #f))
;; (for-each
;; (lambda (custom-type-name)
;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;; (custom-type-test (car custom-type-info))
;; (custom-type-converter (cdr custom-type-info)))
;; (when (and (not res) (custom-type-test arg))
;; (set! res (custom-type-converter arg)))))
;; (hash-table-keys *BBpp_custom_expanders_list*))
;; (if res (BBpp_ res) arg)))
;;
;; (define (BBpp_ arg)
;; (cond
;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;; ((hash-table? arg)
;; (let ((al (hash-table->alist arg)))
;; (BBpp_ (cons HASH_TABLE: al))))
;; ((null? arg) '())
;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; (else (BBpp_custom_converter arg))))
;;
;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;; (pp (BBpp_ arg)))
;(use define-macro)
(define-syntax inspect
(syntax-rules ()
[(_ x)
;; (with-output-to-port (current-error-port)
(printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
|
| ︙ | | |
Modified commonmod.scm
from [2570fcf4eb]
to [837b476e48].
| ︙ | | |
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
+
+
+
+
+
+
+
+
+
+
|
;; testsuite and area utilites
;;
;;======================================================================
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; Globals
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
(define *toppath* #f)
(define *db-keys* #f)
(define *keyvals* #f)
(define (get-full-version)
(conc megatest-version "-" megatest-fossil-hash))
(define (version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
(define *common:denoise* (make-hash-table)) ;; for low noise printing
|
| ︙ | | |
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
221
222
223
224
225
226
227
228
|
-
-
-
-
-
-
-
+
-
|
,(val->alist (cadr entry))))
adat)))
;;======================================================================
;; misc stuff
;;======================================================================
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
;; (set! debug:print-info dbgpinfo))
)
|
Modified configf.scm
from [6390e213ef]
to [a8ff1d05bd].
| ︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
+
+
+
|
;;======================================================================
(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses debugprint))
(include "common_records.scm")
(import debugprint)
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
(if (common:file-exists? cfname)
(list toppath cfname configname)
|
| ︙ | | |
Modified configfmod.scm
from [150f2301e2]
to [5f13eb2f6f].
| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
-
-
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit configfmod))
;; (declare (uses mtargs))
;; (declare (uses debugprint))
|
| ︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
-
-
+
+
|
;; chicken.process-context
;; chicken.process-context.posix
;; chicken.sort
;; chicken.string
;; chicken.time
;; chicken.eval
;;
;; debugprint
;; (prefix mtargs args:)
|
| ︙ | | |
Modified dashboard-context-menu.scm
from [7325252cd1]
to [e159de1324].
| ︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
+
+
+
+
|
(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(import debugprint)
(define (dboard:launch-testpanel run-id test-id)
(let* ((dboardexe (common:find-local-megatest "dashboard"))
(cmd (conc dboardexe
" -test " run-id "," test-id
" &")))
(system cmd)))
|
| ︙ | | |
Modified dashboard-guimonitor.scm
from [60455a8a12]
to [d2ee1578bc].
| ︙ | | |
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
-
|
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
|
| ︙ | | |
Modified dashboard-tests.scm
from [e634889bb3]
to [65ea816136].
| ︙ | | |
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
+
+
+
|
(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(import debugprint)
;;======================================================================
;; C O M M O N
;;======================================================================
(define *dashboard-comment-share-slot* #f)
|
| ︙ | | |
Modified dashboard.scm
from [4ad343f07e]
to [0d8f853388].
| ︙ | | |
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
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
|
+
-
+
+
+
|
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbfile))
(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
|
| ︙ | | |
Modified db.scm
from [a8c5e5bad4]
to [da2478eb1d].
| ︙ | | |
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
|
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
|
-
+
-
-
+
+
+
|
typed-records
matchable
files)
(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
(import dbmod)
(import dbfile)
(import dbmod
dbfile
debugprint)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
|
| ︙ | | |
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
|
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
testname)
res))))
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
(case transport
;; ((fs) obj)
((http fs)
(string-substitute
(regexp "=") "_"
(base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
#t))
((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
(else obj))) ;; rpc
(define (db:string->obj msg #!key (transport 'http))
(case transport
;; ((fs) msg)
((http fs)
(if (string? msg)
(with-input-from-string
(z3:decode-buffer
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t)))
(lambda ()(deserialize)))
(begin
(debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
;; ;; NOTE: Can remove the regex and base64 encoding for zmq
;; (define (db:obj->string obj #!key (transport 'http))
;; (case transport
;; ;; ((fs) obj)
;; ((http fs)
;; (string-substitute
;; (regexp "=") "_"
;; (base64:base64-encode
;; (z3:encode-buffer
;; (with-output-to-string
;; (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
;; #t))
;; ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
;; (else obj))) ;; rpc
;;
;; (define (db:string->obj msg #!key (transport 'http))
;; (case transport
;; ;; ((fs) msg)
;; ((http fs)
;; (if (string? msg)
;; (with-input-from-string
;; (z3:decode-buffer
;; (base64:base64-decode
;; (string-substitute
;; (regexp "_") "=" msg #t)))
;; (lambda ()(deserialize)))
;; (begin
;; (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
;; (print-call-chain (current-error-port))
;; msg))) ;; crude reply for when things go awry
;; ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
;; (else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
|
| ︙ | | |
Modified dbfile.scm
from [ec0a32b2ce]
to [bea959c089].
| ︙ | | |
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
|
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
|
-
+
+
-
-
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit dbfile))
;; (declare (uses debugprint))
;; (import debugprint)
|
| ︙ | | |
Modified dbmod.scm
from [043beb90c3]
to [c1b3b278a4].
| ︙ | | |
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
|
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
|
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit dbmod))
(declare (uses debugprint))
(module dbmod
*
(import scheme chicken data-structures extras)
(import scheme
chicken
ports
s11n
z3
data-structures
extras
(prefix base64 base64:)
message-digest
regex
debugprint
)
(import (prefix sqlite3 sqlite3:)
posix typed-records srfi-18
srfi-69)
(define (db:run-id->dbname run-id)
(cond
((number? run-id)(conc run-id ".db"))
((not run-id) "main.db")
(else run-id)))
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
(case transport
;; ((fs) obj)
((http fs)
(string-substitute
(regexp "=") "_"
(base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
#t))
((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
(else obj))) ;; rpc
(define (db:string->obj msg #!key (transport 'http))
(case transport
;; ((fs) msg)
((http fs)
(if (string? msg)
(with-input-from-string
(z3:decode-buffer
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t)))
(lambda ()(deserialize)))
(begin
(debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
;;======================================================================
;; hash of hashs
;;======================================================================
|
| ︙ | | |
Modified dcommon.scm
from [2cc987e965]
to [960040782d].
| ︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
+
-
+
+
+
|
(use regex typed-records matchable)
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
(declare (uses commonmod))
(declare (uses debugprint))
(import commonmod)
(import commonmod
debugprint
)
;; (declare (uses synchash))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
|
| ︙ | | |
Modified diff-report.scm
from [2363105245]
to [350245269f].
| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
+
+
+
|
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
(declare (unit diff-report))
(declare (uses common))
(declare (uses rmtmod))
(declare (uses debugprint))
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(import debugprint)
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
(for-each
(lambda (item)
(let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
|
| ︙ | | |
Modified env.scm
from [028e47144f]
to [2156bd5c58].
| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit env))
(declare (uses debugprint))
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
(import debugprint)
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
(begin
(exec (sql db "CREATE TABLE envvars (
|
| ︙ | | |
Modified ezsteps.scm
from [aab87817a5]
to [e652536dac].
| ︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
+
-
+
|
z3 csv typed-records pathname-expand matchable)
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses debugprint))
;; (declare (uses sdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(import debugprint)
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(stepinfo (cadr ezstep))
|
| ︙ | | |
Modified genexample.scm
from [c6a2ab2853]
to [83a6a2da50].
| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit genexample))
(declare (uses debugprint))
(use posix regex matchable)
(import debugprint)
(include "db_records.scm")
(define genexample:example-logpro
#<<EOF
;; You should have at least one expect:required. This ensures that your process ran
;; comment out the line below and replace "put pattern here" with a pattern that will
|
| ︙ | | |
Modified items.scm
from [16328a4b96]
to [b819f8ae5b].
| ︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
+
+
+
|
;; (define itemdat '((ripeness "green ripe overripe")
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
(declare (uses debugprint))
(include "common_records.scm")
(import debugprint)
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
(set! hierdepth (length itemlist)))
(let loop ((hed (car itemlist))
|
| ︙ | | |
Modified keys.scm
from [9fa2c0cfa5]
to [d9a1882f80].
| ︙ | | |
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
+
+
+
+
-
-
+
+
-
-
+
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================
(declare (unit keys))
(declare (uses common))
(declare (uses debugprint))
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(use srfi-1 posix regex regex-case srfi-69
(prefix sqlite3 sqlite3:))
(declare (unit keys))
(declare (uses common))
(import debugprint)
(include "key_records.scm")
(include "common_records.scm")
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
(string-intersperse keys ","))
|
| ︙ | | |
Modified launch.scm
from [9881087e2c]
to [fed129a191].
| ︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
+
+
+
|
(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))
(declare (uses debugprint))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
(import debugprint)
;;======================================================================
;; ezsteps
;;======================================================================
;; ezsteps were going to be coded as
;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute
|
| ︙ | | |
Modified lock-queue.scm
from [21543b63ce]
to [8e6c749c60].
| ︙ | | |
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
-
-
+
+
+
+
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
(use (prefix sqlite3 sqlite3:) srfi-18)
|
| ︙ | | |
Modified megatest.scm
from [d11cee8fe2]
to [555218ae3b].
| ︙ | | |
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
|
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
|
-
-
+
+
-
+
+
+
|
(declare (uses rmtmod))
(declare (uses clientmod))
(declare (uses servermod))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))
servermod)
servermod
debugprint
)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
|
| ︙ | | |
Modified mlaunch.scm
from [5bcd34288f]
to [955b765f63].
| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
|
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
-
+
+
|
;; MLAUNCH
;;
;; take jobs from the given queue and keep launching them keeping
;; the cpu load at the targeted level
;;
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
|
Modified mt.scm
from [849e3c135b]
to [1abbf767e0].
| ︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
+
+
+
|
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses runs))
(declare (uses rmtmod))
;; (declare (uses filedb))
(declare (uses debugprint))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(import debugprint)
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
;;======================================================================
;; R U N S
;;======================================================================
|
| ︙ | | |
Modified mtserv.scm
from [e7de2023f5]
to [ad1041ae0e].
| ︙ | | |
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
+
|
matchable
)
;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(define help (conc "
mtserv, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
|
| ︙ | | |
Modified mtut.scm
from [413cf26858]
to [f9bdb0fdb0].
| ︙ | | |
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
+
+
+
|
(prefix sqlite3 sqlite3:)
nanomsg)
(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses debugprint))
(use ducttape-lib)
(import debugprint)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
|
| ︙ | | |
Modified newdashboard.scm
from [a0c1909f88]
to [db5c39b7a4].
| ︙ | | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
+
+
+
|
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(declare (uses debugprint))
;; (declare (uses tree))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(import debugprint)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2011
Usage: dashboard [options]
|
| ︙ | | |
Modified portlogger.scm
from [8344cdf37f]
to [59aa832bb1].
| ︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
+
+
|
(require-extension (srfi 18) extras tcp s11n)
(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))
(declare (unit portlogger))
(declare (uses db))
(declare (uses debugprint))
(import debugprint)
;; lsof -i
(define (portlogger:open-db fname)
(let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
(exists (common:file-exists? fname))
(db (if avail
|
| ︙ | | |
Modified process.scm
from [f525bcbf17]
to [4050043a66].
| ︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
+
+
+
|
;;======================================================================
;; Process convience utils
;;======================================================================
(use regex directory-utils)
(declare (unit process))
(declare (uses debugprint))
(import debugprint)
(define (process:conservative-read port)
(let loop ((res ""))
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
res)))
|
| ︙ | | |
Modified rmt.scm
from [b4412653ef]
to [00e4366063].
| ︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
+
-
+
+
+
|
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(declare (uses debugprint))
(include "common_records.scm")
;; (declare (uses rmtmod))
(import dbfile) ;; rmtmod)
(import dbfile
debugprint
) ;; rmtmod)
;; ;;
;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;; ;;
;;
;; ;; generate entries for ~/.megatestrc with the following
;; ;;
|
| ︙ | | |
Modified rmtmod.scm
from [68caa1e403]
to [32ffde6ac2].
| ︙ | | |
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
|
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
|
+
+
+
-
+
+
+
+
|
;;======================================================================
(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses clientmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses apimod))
(module rmtmod
*
(import scheme
chicken
data-structures
posix
;; regex
srfi-1
srfi-18
srfi-69
extras
|
| ︙ | | |
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
-
+
+
+
|
;; else return #f to let the calling proc know that there is no server available
;;
(define (rmt:get-connection-info areapath) ;; TODO: push areapath down.
(if *runremote*
*runremote*
(begin
(set! *runremote* (client:find-server areapath))
(con-obj-to-str-set! *runremote* db:obj->str)
(con-obj-to-str-set! *runremote* db:obj->string)
(con-str-to-obj-set! *runremote* db:string->obj)
(con-host-set! *runremote* (get-host-name))
(con-pid-set! *runremote* (current-process-id))
(con-areapath-set! *runremote* areapath)
*runremote*)))
#;(let* ((cinfo (if (remote? runremote)
(remote-conndat runremote)
#f)))
(if cinfo
cinfo
|
| ︙ | | |
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
-
+
|
;;======================================================================
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
(let* ((con (rmt:get-connection-info areapath)))
(let* ((con (rmt:get-connection-info *toppath*)))
(client:send-receive con cmd params)))
;; 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
|
| ︙ | | |
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
|
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
|
-
+
|
(if (> tot 10)
(cons newmax-cmd currmax)
(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))
#;(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))
(dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
(read-only (not (file-write-access? db-file-path)))
(start (current-milliseconds))
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
|
| ︙ | | |
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
|
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
|
-
+
|
(if qry-is-write
(let ((start-time (current-seconds)))
(mutex-lock! *db-multi-sync-mutex*)
/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
(mutex-unlock! *db-multi-sync-mutex*)))))
res))
(define (rmt:send-receive-no-auto-client-setup runremote cmd run-id params)
#;(define (rmt:send-receive-no-auto-client-setup runremote cmd run-id params)
(let* ((run-id (if run-id run-id 0))
(res (http-transport:client-api-send-receive run-id runremote cmd params)))
(if (and res (vector-ref res 0))
(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
#f)))
;;======================================================================
|
| ︙ | | |
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
|
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
|
-
+
|
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature))))
;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup runremote)
#;(define (rmt:login-no-auto-client-setup runremote)
(rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))
;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible
;;
(define (rmt:general-call stmtname run-id . params)
(rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
|
| ︙ | | |
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
|
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
|
-
+
|
(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
(print-call-chain (current-error-port))
#f)))
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
#;(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
(assert (number? run-id) "FATAL: Run id required.")
(let* ((test-path (if (string? work-area)
work-area
(rmt:test-get-rundir-from-test-id run-id test-id))))
(debug:print 3 *default-log-port* "TEST PATH: " test-path)
(open-test-db test-path)))
|
| ︙ | | |
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
|
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
|
-
-
+
+
|
;; 2. Continue as above
;;
;;(define (rmt:get-steps-for-test run-id test-id)
;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
(assert (number? run-id) "FATAL: Run id required.")
(let* ((state (items:check-valid-items "state" state-in))
(status (items:check-valid-items "status" status-in)))
(let* ((state state-in) ;; (items:check-valid-items "state" state-in))
(status status-in)) ;; (items:check-valid-items "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
(define (rmt:delete-steps-for-test! run-id test-id)
|
| ︙ | | |
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
|
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
(assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
(define (rmt:test-get-archive-block-info archive-block-id)
(rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
(define (rmtmod:calc-ro-mode runremote *toppath*)
(if (and runremote
(remote-ro-mode-checked runremote))
(remote-ro-mode runremote)
(let* ((mtcfgfile (conc *toppath* "/megatest.config"))
(ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
(if runremote
(begin
(remote-ro-mode-set! runremote ro-mode)
(remote-ro-mode-checked-set! runremote #t)
ro-mode)
ro-mode))))
(define (extras-readonly-mode rmt-mutex log-port cmd params)
(mutex-unlock! rmt-mutex)
(debug:print-info 12 log-port "rmt:send-receive, case 3")
(debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
#f)
(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
(debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
(mutex-lock! *rmt-mutex*)
(http-transport:close-connections runremote)
(remote-server-url-set! runremote #f)
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
(if (and (vector? res)
(eq? (vector-length res) 2)
(eq? (vector-ref res 1) 'overloaded)) ;; since we are
;; looking at the
;; data to carry the
;; error we'll use a
;; fairly obtuse
;; combo to minimise
;; the chances of
;; some sort of
;; collision. this
;; is the case where
;; the returned data
;; is bad or the
;; server is
;; overloaded and we
;; want to ease off
;; the queries
(let ((wait-delay (+ attemptnum (* attemptnum 10))))
(debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
(mutex-lock! *rmt-mutex*)
(http-transport:close-connections runremote)
(set! *runremote* #f) ;; force starting over
(mutex-unlock! *rmt-mutex*)
(thread-sleep! wait-delay)
(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
res)) ;; All good, return res
#;(set-functions rmt:send-receive remote-server-url-set!
http-transport:close-connections remote-conndat-set!
debug:print debug:print-info
remote-ro-mode remote-ro-mode-set!
remote-ro-mode-checked-set! remote-ro-mode-checked)
;;
;; (define (rmtmod:calc-ro-mode runremote *toppath*)
;; (if (and runremote
;; (remote-ro-mode-checked runremote))
;; (remote-ro-mode runremote)
;; (let* ((mtcfgfile (conc *toppath* "/megatest.config"))
;; (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
;; (if runremote
;; (begin
;; (remote-ro-mode-set! runremote ro-mode)
;; (remote-ro-mode-checked-set! runremote #t)
;; ro-mode)
;; ro-mode))))
;;
;; (define (extras-readonly-mode rmt-mutex log-port cmd params)
;; (mutex-unlock! rmt-mutex)
;; (debug:print-info 12 log-port "rmt:send-receive, case 3")
;; (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
;; #f)
;;
;; (define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
;; (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
;; (mutex-lock! *rmt-mutex*)
;; (http-transport:close-connections runremote)
;; (remote-server-url-set! runremote #f)
;; (mutex-unlock! *rmt-mutex*)
;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
;; (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;
;; (define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
;; (if (and (vector? res)
;; (eq? (vector-length res) 2)
;; (eq? (vector-ref res 1) 'overloaded)) ;; since we are
;; ;; looking at the
;; ;; data to carry the
;; ;; error we'll use a
;; ;; fairly obtuse
;; ;; combo to minimise
;; ;; the chances of
;; ;; some sort of
;; ;; collision. this
;; ;; is the case where
;; ;; the returned data
;; ;; is bad or the
;; ;; server is
;; ;; overloaded and we
;; ;; want to ease off
;; ;; the queries
;; (let ((wait-delay (+ attemptnum (* attemptnum 10))))
;; (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
;; (mutex-lock! *rmt-mutex*)
;; (http-transport:close-connections runremote)
;; (set! *runremote* #f) ;; force starting over
;; (mutex-unlock! *rmt-mutex*)
;; (thread-sleep! wait-delay)
;; (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;; res)) ;; All good, return res
;;
;; #;(set-functions rmt:send-receive remote-server-url-set!
;; http-transport:close-connections remote-conndat-set!
;; debug:print debug:print-info
;; remote-ro-mode remote-ro-mode-set!
;; remote-ro-mode-checked-set! remote-ro-mode-checked)
;;
)
|
Modified runconfig.scm
from [66b9c38588]
to [6913a95308].
| ︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
-
+
+
+
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
(use format directory-utils)
|
| ︙ | | |
Modified runs.scm
from [292b302d70]
to [db1439c273].
| ︙ | | |
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
+
+
|
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
(declare (uses debugprint))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(import debugprint)
;; (include "debugger.scm")
;; use this struct to facilitate refactoring
;;
(defstruct runs:dat
reglen regfull
|
| ︙ | | |
Modified servermod.scm
from [ed8ceb5dcd]
to [b3e225a5e9].
| ︙ | | |
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
|
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
|
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit servermod))
(declare (uses artifacts))
(declare (uses debugprint))
(use md5 message-digest posix typed-records extras)
(module servermod
*
(import scheme
chicken
extras
md5
message-digest
ports
posix
srfi-18
typed-records
data-structures
artifacts
debugprint
)
(defstruct srv
(areapath #f)
(host #f)
(pid #f)
(type #f)
|
| ︙ | | |
Modified subrun.scm
from [8e4ec606e5]
to [68aa532b1d].
| ︙ | | |
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
|
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
|
-
-
-
+
+
+
+
+
+
+
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
|
| ︙ | | |
Modified tasks.scm
from [abd648b927]
to [3a4630abf8].
| ︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
+
-
+
+
+
-
|
(declare (unit tasks))
(declare (uses dbfile))
(declare (uses db))
(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))
(declare (uses debugprint))
(import dbfile)
(import dbfile
debugprint
)
;; (import pgdb) ;; pgdb is a module
(include "task_records.scm")
|
| ︙ | | |
Modified tdb.scm
from [d3b22aeea7]
to [c43cba4b5d].
| ︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
+
+
+
|
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses clientmod))
(declare (uses mt))
(declare (uses db))
(declare (uses debugprint))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(import debugprint)
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
;;======================================================================
|
| ︙ | | |
Modified tests.scm
from [d338c8419d]
to [cbdf45c29c].
| ︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
+
+
+
|
(declare (uses commonmod))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses servermod))
;;(declare (uses stml2))
(declare (uses debugprint))
(import debugprint)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod)
(require-library stml)
(include "common_records.scm")
|
| ︙ | | |
Modified tree.scm
from [0e8e68fe0a]
to [018afa4bfc].
| ︙ | | |
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
+
+
+
|
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(declare (uses debugprint))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(import debugprint)
;;======================================================================
;; T R E E S T U F F
;;======================================================================
;; path is a list of nodes, each the child of the previous
;; this routine returns the id so another node can be added
|
| ︙ | | |