This is equivalent to a diff from
cee15a9d94
to bbdb404874
Modified apimod.scm
from [c5b4d2905e]
to [49fb14301c].
︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
-
+
+
+
|
(declare (uses debugprint))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))
(module apimod
*
(
api:dispatch-request
)
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)
(import dbmod)
(import dbfile)
|
︙ | | |
Modified archivemod.scm
from [ddced4be70]
to [5b21746964].
︙ | | |
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
+
+
+
+
+
+
-
+
+
+
|
(declare (uses mtmod))
(declare (uses dbmod))
(declare (uses dbfile))
(use srfi-69)
(module archivemod
(
archive:get-archive-disks
archive:allocate-new-archive-block
archive:get-timestamp-dir
archive:megatest-db
archive:bup-get-data
*
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
-
+
|
srfi-13
srfi-18
srfi-69
typed-records
z3
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;;======================================================================
;;
;;======================================================================
;; ;; NOT CURRENTLY USED
|
︙ | | |
Modified common.scm
from [58be7ce4cf]
to [ba3517865c].
︙ | | |
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
-
+
|
(import commonmod
processmod
debugprint
configfmod
rmtmod
(prefix mtargs args:))
(include "common_records.scm")
;; (include "common_records.scm")
;;======================================================================
;; (define *common:telemetry-log-state* 'startup)
|
︙ | | |
Modified commonmod.scm
from [5100c657f0]
to [26ca4d0bed].
︙ | | |
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
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
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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
|
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
typed-records
z3)
(import stml2
)
(module commonmod
(
keys->valslots
item-list->path
common:human-time
number-of-processes-running
get-normalized-cpu-load
common:find-local-megatest
*
common:get-intercept
common:get-num-cpus
common:get-cpu-load
common:hms-string->seconds
seconds->time-string
common:get-megatest-exe
megatest-version
common:get-toppath
common:generic-ssh
common:file-exists?
common:with-env-vars
common:nice-path
common:get-fields
common:get-normalized-cpu-load
common:unix-ping
common:get-normalized-cpu-load
;; globals
*common:badly-ended-states*
*common:dont-roll-up-states*
*common:ended-states*
*common:not-started-ok-statuses*
*common:running-states*
*common:std-states*
*common:std-statuses*
*common:well-ended-states*
*configdat*
*configinfo*
*db-access-allowed*
*db-api-call-time*
*db-cache-path*
*db-keys*
*default-area-tag*
*host-loads*
*keyvals*
*logged-in-clients*
*my-client-signature*
*on-exit-procs*
*pkts-info*
*pre-reqs-met-cache*
*runremote*
*server-id*
*server-info*
*target*
*task-db*
*testconfigs*
*time-to-exit*
*toppath*
*transport-type*
any->number-if-possible
common:special-sort
keys:target-set-args
getenv
setenv
safe-setenv
commonmod:get-cpu-load
get-area-path-signature
common:simple-file-lock
common:low-noise-print
common:get-create-writeable-dir
common:real-path
val->alist
client:get-signature
common:get-color-from-status
seconds->year-work-week/day-time
common:simple-file-release-lock
common:simple-file-lock-and-wait
tests:lookup-itemmap
tests:match->sqlqry
runs:get-std-run-fields
common:min-max
common:max
common:sum
keys:target->keyval
db:patt->like
rmt:transport-mode
common:version-signature
keys->keystr
keys:config-get-fields
common:make-tmpdir-name
db:test-get-status
db:test-get-state
db:test-get-event_time
db:test-get-item-path
db:test-get-testname
db:test-get-id
db:test-get-comment
db:test-get-run_duration
db:test-get-rundir
tests:match
patt-list-match
common:pkts-spec
sdb:qry
seconds->work-week/day-time
tdb:step-get-comment
seconds->hr-min-sec
any->number
tdb:step-get-logfile
tdb:step-get-event_time
tdb:step-get-status
tdb:step-get-state
tdb:step-get-id
tdb:step-get-stepname
db:test-make-full-name
common:htree->html
common:list->htree
tdb:steps-table-get-log-file
tdb:steps-table-get-runtime
tdb:steps-table-get-status
tdb:steps-table-get-end
tdb:steps-table-get-start
tdb:steps-table-get-stepname
tdb:step-get-last_update
tdb:step-get-test_id
db:test-get-run_id
db:test-get-final_logf
tests:testqueue-get-item_path
tests:testqueue-get-itemdat
tests:testqueue-get-testname
tests:testqueue-get-priority
tests:testqueue-set-priority!
tests:testqueue-get-testconfig
tests:testqueue-get-waitons
tasks:wait-on-journal
common:get-area-path-signature
db:test-get-last_update
db:test-get-archived
db:test-get-uname
db:test-get-diskfree
db:test-get-cpuload
db:test-get-process_id
db:test-get-host
db:test-data-get-last_update
db:test-data-get-type
db:test-data-get-status
db:test-data-get-comment
db:test-data-get-units
db:test-data-get-tol
db:test-data-get-expected
db:test-data-get-value
db:test-data-get-variable
db:test-data-get-category
db:test-data-get-test_id
db:test-data-get-id
host-last-cpuload
host-last-update
host-last-cpuload-set!
host-last-update-set!
host-reachable-set!
make-host
host-last-used-set!
host-reachable
host-last-used
common:alist-ref/default
common:val->alist
common:in-running-test?
common:without-vars
common:get-megatest-exe-path
common:get-megatest-exe-dir
common:get-param-mapping
common:get-mtexe
db:test-get-is-toplevel
seconds->quarter
*globalexitstatus*
tests:testqueue-set-items!
tests:testqueue-get-items
*runconfigdat*
*passnum*
*already-seen-runconfig-info*
common:directory-writable?
common:dir-clean-up
common:fail-safe
common:list-or-null
*toptest-paths*
common:directory-exists?
*configstatus*
*last-launch*
*launch-setup-mutex*
commonmod:is-test-alive
alist->env-vars
*env-vars-by-run-id*
common:get-signature
common:join-backgrounded-threads
tests:glob-like-match
common:send-thunk-to-background-thread
db:test-get-fullname
common:clear-caches
db:mintest-get-event_time
*test-meta-updated*
tests:testqueue-set-item_path!
tests:testqueue-set-itemdat!
make-tests:testqueue
megatest-fossil-hash
common:steps-can-proceed-given-status-sym
status-sym->string
common:worse-status-sym
common:logpro-exit-code->status-sym
save-environment-as-files
assoc/default
common:read-encoded-string
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix base64 base64:)
|
︙ | | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
|
+
+
|
srfi-1
srfi-18
srfi-69
typed-records
system-information
debugprint
megatest-fossil-hash
)))
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
|
︙ | | |
383
384
385
386
387
388
389
390
391
392
393
394
395
396
|
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
|
+
|
(define *fdb* #f)
(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
;; environment vars handy stuff from common.scm
;;
(define getenv get-environment-variable)
(define (safe-setenv key val)
(if (or (substring-index "!" key)
(substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
(substring-index "." key)) ;; periods are not allowed in environment variables
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
(if (and (string? val)
(string? key))
|
︙ | | |
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
|
803
804
805
806
807
808
809
810
811
812
813
814
815
816
|
-
-
-
|
;; convert string a=1; b=2; c=a silly thing; d=
(let ((valstr (lookup cfgdat section var)))
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define (common:make-tmpdir-name areapath tmpadj)
(let* ((area (pathname-file areapath))
(dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
dname))
|
︙ | | |
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
|
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
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
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
;;======================================================================
;; db_records.scm
;;======================================================================
;;======================================================================
;; dbstruct
;;======================================================================
(define (make-db:test)(make-vector 20))
(define (db:test-get-id vec) (vector-ref vec 0))
(define (db:test-get-run_id vec) (vector-ref vec 1))
(define (db:test-get-testname vec) (vector-ref vec 2))
(define (db:test-get-state vec) (vector-ref vec 3))
(define (db:test-get-status vec) (vector-ref vec 4))
(define (db:test-get-event_time vec) (vector-ref vec 5))
(define (db:test-get-host vec) (vector-ref vec 6))
(define (db:test-get-cpuload vec) (vector-ref vec 7))
(define (db:test-get-diskfree vec) (vector-ref vec 8))
(define (db:test-get-uname vec) (vector-ref vec 9))
;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir vec) (vector-ref vec 10))
(define (db:test-get-item-path vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf vec) (vector-ref vec 13))
(define (db:test-get-comment vec) (vector-ref vec 14))
(define (db:test-get-process_id vec) (vector-ref vec 16))
(define (db:test-get-archived vec) (vector-ref vec 17))
(define (db:test-get-last_update vec) (vector-ref vec 18))
)
;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
(define (db:test-get-fullname vec)
(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
(if (equal? itempath "") testname (conc testname "/" itempath)))
;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state! vec val)(vector-set! vec 3 val))
(define (db:test-set-status! vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
;; Test record utility functions
;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
(and (equal? (db:test-get-item-path vec) "") ;; test is not an item
(equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id vec) (vector-ref vec 0))
(define (db:mintest-get-run_id vec) (vector-ref vec 1))
(define (db:mintest-get-testname vec) (vector-ref vec 2))
(define (db:mintest-get-state vec) (vector-ref vec 3))
(define (db:mintest-get-status vec) (vector-ref vec 4))
(define (db:mintest-get-event_time vec) (vector-ref vec 5))
(define (db:mintest-get-item_path vec) (vector-ref vec 6))
;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id vec) (vector-ref vec 0))
(define (db:testmeta-get-testname vec) (vector-ref vec 1))
(define (db:testmeta-get-author vec) (vector-ref vec 2))
(define (db:testmeta-get-owner vec) (vector-ref vec 3))
(define (db:testmeta-get-description vec) (vector-ref vec 4))
(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
(define (db:testmeta-get-tags vec) (vector-ref vec 9))
(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
;;======================================================================
;; S I M P L E R U N
;;======================================================================
;; (defstruct id "runname" "state" "status" "owner" "event_time"
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id vec) (vector-ref vec 0))
(define (db:test-data-get-test_id vec) (vector-ref vec 1))
(define (db:test-data-get-category vec) (vector-ref vec 2))
(define (db:test-data-get-variable vec) (vector-ref vec 3))
(define (db:test-data-get-value vec) (vector-ref vec 4))
(define (db:test-data-get-expected vec) (vector-ref vec 5))
(define (db:test-data-get-tol vec) (vector-ref vec 6))
(define (db:test-data-get-units vec) (vector-ref vec 7))
(define (db:test-data-get-comment vec) (vector-ref vec 8))
(define (db:test-data-get-status vec) (vector-ref vec 9))
(define (db:test-data-get-type vec) (vector-ref vec 10))
(define (db:test-data-get-last_update vec) (vector-ref vec 11))
(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
;;======================================================================
;; S T E P S
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id vec) (vector-ref vec 0))
(define (tdb:step-get-test_id vec) (vector-ref vec 1))
(define (tdb:step-get-stepname vec) (vector-ref vec 2))
(define (tdb:step-get-state vec) (vector-ref vec 3))
(define (tdb:step-get-status vec) (vector-ref vec 4))
(define (tdb:step-get-event_time vec) (vector-ref vec 5))
(define (tdb:step-get-logfile vec) (vector-ref vec 6))
(define (tdb:step-get-comment vec) (vector-ref vec 7))
(define (tdb:step-get-last_update vec) (vector-ref vec 8))
(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
;; ;; The data structure for handing off requests via wire
;; (define (make-cdb:packet)(make-vector 6))
;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1))
;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2))
;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
;; (define (cdb:packet-get-params vec) (vector-ref vec 4))
;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5))
;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
;;======================================================================
;; key_records
;;======================================================================
(define (keys->valslots keys) ;; => ?,?,? ....
(string-intersperse (map (lambda (x) "?") keys) ","))
;; (define (keys->key/field keys . additional)
;; (string-join (map (lambda (k)(conc k " TEXT"))
;; (append keys additional)) ","))
(define (item-list->path itemdat)
(if (list? itemdat)
(string-intersperse (map cadr itemdat) "/")
""))
;;======================================================================
;; test_records
;;======================================================================
;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 7 #f))
(define (tests:testqueue-get-testname vec) (vector-ref vec 0))
(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
(define (tests:testqueue-get-waitons vec) (vector-ref vec 2))
(define (tests:testqueue-get-priority vec) (vector-ref vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define (tests:testqueue-get-items vec) (vector-ref vec 4))
(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
(define (tests:testqueue-get-item_path vec) (vector-ref vec 6))
(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
)
|
Modified configfmod.scm
from [8c4c9bcd5b]
to [8facfee8f8].
︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
|
(declare (uses commonmod))
(declare (uses processmod))
(declare (uses mtargs))
(use regex regex-case)
(module configfmod
(
lookup
configf:lookup
get-section
configf:get-section
configf:lookup-number
read-config
runconfigs-get
configf:section-vars
configf:read-alist
configf:config->alist
configf:alist->config
configf:set-section-var
*
find-and-read-config
common:args-get-target
configf:eval-string-in-environment
)
(import scheme
chicken
extras
files
matchable
ports
|
︙ | | |
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
+
+
|
#f
(let ((match (assoc var sectdat)))
(if match ;; (and match (list? match)(> (length match) 1))
(cadr match)
#f))
))
#f))
(define lookup configf:lookup)
;; use to have definitive setting:
;; [foo]
;; var yes
;;
;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;
|
︙ | | |
232
233
234
235
236
237
238
239
240
241
242
243
244
245
|
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
+
+
|
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
'()
(map car sectdat))))
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define get-section configf:get-section)
(define (configf:set-section-var cfgdat section var val)
(let ((sectdat (configf:get-section cfgdat section)))
(hash-table-set! cfgdat section
(configf:assoc-safe-add sectdat var val))))
;;======================================================================
|
︙ | | |
Modified cpumod.scm
from [33a302895b]
to [338168220c].
︙ | | |
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
+
-
+
|
(declare (unit cpumod))
(declare (uses debugprint))
(declare (uses mtargs))
(use srfi-69)
(module cpumod
()
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified dashboard-context-menu.scm
from [a9287541e5]
to [c308418947].
︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
-
+
|
(import (prefix iup iup:))
(use canvas-draw)
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(import commonmod
configfmod
rmtmod
testsmod
|
︙ | | |
Modified dashboard-guimonitor.scm
from [14af79287f]
to [d7f5af88af].
︙ | | |
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
-
+
|
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(define (control-panel db tdb keys)
(let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
(key-params (make-hash-table))
|
︙ | | |
Modified dashboard-tests.scm
from [9f47337a67]
to [5c975d5a1c].
︙ | | |
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
-
+
|
dbfile
tasksmod
testsmod
runsmod
subrunmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;;======================================================================
;; C O M M O N
;;======================================================================
|
︙ | | |
Modified dashboard.scm
from [0974058261]
to [e0e854db49].
︙ | | |
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
-
+
-
+
|
stml2
megatestmod
tasksmod
runsmod
testsmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")
|
︙ | | |
Modified db_records.scm
from [d1dae58171]
to [1501321c72].
︙ | | |
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
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
|
11
12
13
14
15
16
17
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; 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/>.
;;======================================================================
;; dbstruct
;;======================================================================
(define (make-db:test)(make-vector 20))
(define (db:test-get-id vec) (vector-ref vec 0))
(define (db:test-get-run_id vec) (vector-ref vec 1))
(define (db:test-get-testname vec) (vector-ref vec 2))
(define (db:test-get-state vec) (vector-ref vec 3))
(define (db:test-get-status vec) (vector-ref vec 4))
(define (db:test-get-event_time vec) (vector-ref vec 5))
(define (db:test-get-host vec) (vector-ref vec 6))
(define (db:test-get-cpuload vec) (vector-ref vec 7))
(define (db:test-get-diskfree vec) (vector-ref vec 8))
(define (db:test-get-uname vec) (vector-ref vec 9))
;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir vec) (vector-ref vec 10))
(define (db:test-get-item-path vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf vec) (vector-ref vec 13))
(define (db:test-get-comment vec) (vector-ref vec 14))
(define (db:test-get-process_id vec) (vector-ref vec 16))
(define (db:test-get-archived vec) (vector-ref vec 17))
(define (db:test-get-last_update vec) (vector-ref vec 18))
;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
(define (db:test-get-fullname vec)
(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
(if (equal? itempath "") testname (conc testname "/" itempath)))
;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state! vec val)(vector-set! vec 3 val))
(define (db:test-set-status! vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
;; Test record utility functions
;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
(and (equal? (db:test-get-item-path vec) "") ;; test is not an item
(equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id vec) (vector-ref vec 0))
(define (db:mintest-get-run_id vec) (vector-ref vec 1))
(define (db:mintest-get-testname vec) (vector-ref vec 2))
(define (db:mintest-get-state vec) (vector-ref vec 3))
(define (db:mintest-get-status vec) (vector-ref vec 4))
(define (db:mintest-get-event_time vec) (vector-ref vec 5))
(define (db:mintest-get-item_path vec) (vector-ref vec 6))
;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id vec) (vector-ref vec 0))
(define (db:testmeta-get-testname vec) (vector-ref vec 1))
(define (db:testmeta-get-author vec) (vector-ref vec 2))
(define (db:testmeta-get-owner vec) (vector-ref vec 3))
(define (db:testmeta-get-description vec) (vector-ref vec 4))
(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
(define (db:testmeta-get-tags vec) (vector-ref vec 9))
(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
;;======================================================================
;; S I M P L E R U N
;;======================================================================
;; (defstruct id "runname" "state" "status" "owner" "event_time"
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id vec) (vector-ref vec 0))
(define (db:test-data-get-test_id vec) (vector-ref vec 1))
(define (db:test-data-get-category vec) (vector-ref vec 2))
(define (db:test-data-get-variable vec) (vector-ref vec 3))
(define (db:test-data-get-value vec) (vector-ref vec 4))
(define (db:test-data-get-expected vec) (vector-ref vec 5))
(define (db:test-data-get-tol vec) (vector-ref vec 6))
(define (db:test-data-get-units vec) (vector-ref vec 7))
(define (db:test-data-get-comment vec) (vector-ref vec 8))
(define (db:test-data-get-status vec) (vector-ref vec 9))
(define (db:test-data-get-type vec) (vector-ref vec 10))
(define (db:test-data-get-last_update vec) (vector-ref vec 11))
(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
;;======================================================================
;; S T E P S
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id vec) (vector-ref vec 0))
(define (tdb:step-get-test_id vec) (vector-ref vec 1))
(define (tdb:step-get-stepname vec) (vector-ref vec 2))
(define (tdb:step-get-state vec) (vector-ref vec 3))
(define (tdb:step-get-status vec) (vector-ref vec 4))
(define (tdb:step-get-event_time vec) (vector-ref vec 5))
(define (tdb:step-get-logfile vec) (vector-ref vec 6))
(define (tdb:step-get-comment vec) (vector-ref vec 7))
(define (tdb:step-get-last_update vec) (vector-ref vec 8))
(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
;; ;; The data structure for handing off requests via wire
;; (define (make-cdb:packet)(make-vector 6))
;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1))
;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2))
;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
;; (define (cdb:packet-get-params vec) (vector-ref vec 4))
;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5))
;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
|
Modified dbmod.scm
from [6fddda802c]
to [4ab5fd7962].
︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
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
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
|
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))
(module dbmod
(
db:test-get-event_time
db:test-get-item-path
db:test-get-testname
db:get-value-by-header
*
db:get-subdb
db:multi-db-sync
dbmod:open-dbmoddb
dbmod:run-id->dbfname
db:roll-up-rules
db:get-all-state-status-counts-for-test
db:test-set-state-status-db
db:general-call
db:convert-test-itempath
db:test-data-rollup
db:keep-trying-until-true
db:get-test-info-by-id
db:with-db
db:get-test-id
db:get-test-info
dbmod:print-db-stats
db:get-keys
db:open-no-sync-db
db:add-stats
;; dbr:counts record accessors
dbr:counts->alist
db:add-var
db:archive-register-block-name
db:archive-register-disk
db:create-all-triggers
db:csv->test-data
db:dec-var
db:del-var
db:delete-old-deleted-test-records
db:delete-run
db:delete-steps-for-test!
db:delete-test-records
db:drop-all-triggers
db:get-all-run-ids
db:get-all-runids
db:get-changed-record-ids
db:get-changed-record-run-ids
db:get-changed-record-test-ids
db:get-count-tests-running
db:get-count-tests-running-for-run-id
db:get-count-tests-running-for-testname
db:get-count-tests-running-in-jobgroup
db:get-data-info-by-id
db:get-key-val-pairs
db:get-key-vals
db:get-latest-host-load
db:get-main-run-stats
db:get-matching-previous-test-run-records
db:get-not-completed-cnt
db:get-num-runs
db:get-prereqs-not-met
db:get-prev-run-ids
db:get-raw-run-stats
db:get-run-ids-matching-target
db:get-run-info
db:get-run-name-from-id
db:get-run-record-ids
db:get-run-state
db:get-run-state-status
db:get-run-stats
db:get-run-status
db:get-run-times
db:get-runs
db:get-runs-by-patt
db:get-runs-cnt-by-patt
db:get-steps-data
db:get-steps-for-test
db:get-steps-info-by-id
db:get-target
db:get-targets
db:get-test-state-status-by-id
db:get-test-times
db:get-testinfo-state-status
db:get-tests-for-run
db:get-tests-for-run-mindata
db:get-tests-for-run-state-status
db:get-tests-tags
db:get-toplevels-and-incompletes
db:get-var
db:have-incompletes?
db:inc-var
db:initialize-main-db
db:insert-run
db:insert-test
db:lock/unlock-run
db:login
db:read-test-data
db:read-test-data-varpatt
db:register-run
db:set-run-state-status
db:set-run-status
db:set-state-status-and-roll-up-run
db:set-var
db:simple-get-runs
db:test-get-archive-block-info
db:test-get-logfile-info
db:test-get-paths-matching-keynames-target-new
db:test-get-records-for-index-file
db:test-get-rundir-from-test-id
db:test-get-top-process-pid
db:test-set-archive-block-id
db:test-set-state-status
db:test-set-top-process-pid
db:test-toplevel-num-items
db:testmeta-add-record
db:testmeta-get-record
db:testmeta-update-field
db:teststep-set-status!
db:top-test-set-per-pf-counts
db:update-run-event_time
db:update-run-stats
db:update-tesdata-on-repilcate-db
tasks:add
tasks:find-task-queue-records
tasks:get-last
tasks:set-state-given-param-key
*db-stats*
dbmod:nfs-get-dbstruct
*db-stats-mutex*
db:get-header
db:get-rows
db:get-changed-run-ids
db:set-sync
db:setup
db:logpro-dat->csv
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
data-structures
|
︙ | | |
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
-
+
|
commonmod
configfmod
dbfile
debugprint
mtmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
|
︙ | | |
Modified dcommon.scm
from [d0a5600c78]
to [bda06bf5b7].
︙ | | |
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
-
+
|
configfmod
rmtmod
testsmod
dbmod
debugprint)
(include "megatest-version.scm")
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
;; yes, this is non-ideal
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
|
︙ | | |
Modified diff-report.scm
from [939aa5e4ab]
to [2fd0ddce36].
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
|
(declare (uses debugprint))
(declare (uses rmtmod))
(declare (uses commonmod))
(import commonmod
rmtmod
debugprint)
(include "common_records.scm")
;; (include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
|
︙ | | |
Modified ezstepsmod.scm
from [0f672c5b01]
to [ff6068567c].
︙ | | |
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
-
+
|
(declare (uses testsmod))
(declare (uses runsmod))
(declare (uses fsmod))
(use srfi-69)
(module ezstepsmod
*
()
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
-
+
|
tasksmod
subrunmod
testsmod
runsmod
fsmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
|
︙ | | |
Modified fsmod.scm
from [57a2c983b3]
to [5fe1b052db].
︙ | | |
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
+
+
+
+
+
+
-
+
+
|
(declare (uses configfmod))
(declare (uses commonmod))
(declare (uses processmod))
(use srfi-69)
(module fsmod
(
get-df
get-uname
common:get-disk-with-most-free-space
common:get-disk-space-used
common:check-db-dir-and-exit-if-insufficient
*
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified key_records.scm
from [55f6701b87]
to [8cb99c889a].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
14
15
16
17
18
19
20
|
-
-
-
-
-
-
-
-
-
-
-
-
|
;; 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/>.
;;======================================================================
(define (keys->valslots keys) ;; => ?,?,? ....
(string-intersperse (map (lambda (x) "?") keys) ","))
;; (define (keys->key/field keys . additional)
;; (string-join (map (lambda (k)(conc k " TEXT"))
;; (append keys additional)) ","))
(define (item-list->path itemdat)
(if (list? itemdat)
(string-intersperse (map cadr itemdat) "/")
""))
|
Modified launch.scm
from [60c51037a0]
to [08710a0aca].
︙ | | |
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
-
+
|
typed-records pathname-expand matchable)
(import (prefix base64 base64:)
(prefix sqlite3 sqlite3:)
(prefix mtargs args:)
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "megatest-fossil-hash.scm")
(import commonmod
processmod
configfmod
|
︙ | | |
Modified launchmod.scm
from [46f91d6b1b]
to [a0b277c06f].
︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
-
+
+
|
(declare (uses testsmod))
(declare (uses runsmod))
(declare (uses fsmod))
(use srfi-69)
(module launchmod
*
(
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
-
+
|
tasksmod
subrunmod
testsmod
runsmod
fsmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "megatest-fossil-hash.scm")
;;======================================================================
;; ezsteps
;;======================================================================
|
︙ | | |
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
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
1027
1028
1029
1030
1031
1032
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
|
978
979
980
981
982
983
984
985
986
987
988
989
990
991
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
#f)))
;; now wait on that process if all is correct
;; periodically update the db with runtime
;; when the process exits look at the db, if still RUNNING after 10 seconds set
;; state/status appropriately
(process-wait pid)))
;;======================================================================
;; Maintenance
;;======================================================================
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
(let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
(test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
(rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)))
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
;;
;; NOT EASY TO MIGRATE TO db{file,mod}
;;
(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
;; The default running-deadtime is 720 seconds = 12 minutes.
;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
(deadtime-trim (or ovr-deadtime cfg-deadtime))
(server-start-allowance 200)
(server-overloaded-budget 200)
(launch-monitor-off-time (or test-stats-update-period 30))
(launch-monitor-on-time-budget 30)
(launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
(remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
(remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
(running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
(debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
(debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
(let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)))
(set! oldlaunched (list-ref dat 1))
(set! toplevels (list-ref dat 2))
(set! incompleted (list-ref dat 0)))
(debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
(length toplevels) " old LAUNCHED toplevel tests and "
(length incompleted) " tests marked RUNNING but apparently dead.")
;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
;;
;; (db:delay-if-busy dbdat)
(let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
(all-ids (append min-incompleted-ids (map car oldlaunched))))
(if (> (length all-ids) 0)
(begin
;; (launch:is-test-alive "localhost" 435)
(debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
" as DEAD")
(for-each
(lambda (test-id)
(let* ((tinfo (rmt:get-test-info-by-id run-id test-id))
(run-dir (db:test-get-rundir tinfo))
(host (db:test-get-host tinfo))
(pid (db:test-get-process_id tinfo))
(result (rmt:get-status-from-final-status-file run-dir)))
(if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result)))
(begin
(debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
(rmt:set-state-status-and-roll-up-items
run-id test-id 'foo "COMPLETED" "PASS"
"Test stopped responding but it has PASSED; marking it PASS in the DB."))
(let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored.
(commonmod:is-test-alive host pid))))
(if is-alive
(debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
" has a process on pid " pid ", NOT setting to DEAD.")
(begin
(debug:print 0 *default-log-port* "INFO: test " test-id
" final state/status is not COMPLETED/PASS. It is " result)
(rmt:set-state-status-and-roll-up-items
run-id test-id 'foo "COMPLETED" "DEAD"
"Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
;; call end of eud of run detection for posthook - from merge, is it needed?
;; (launch:end-of-run-check run-id)
all-ids)
)))))
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (ezsteps: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))
;; (let ((info (cadr ezstep)))
|
︙ | | |
Modified megatest.scm
from [faeb3396e2]
to [72e4d22039].
︙ | | |
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
-
+
|
;; 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/>.
;;
;; (include "common.scm")
(include "megatest-version.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
|
︙ | | |
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
-
+
|
rmtmod
launchmod
fsmod
)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
(use readline apropos json http-client directory-utils typed-records)
|
︙ | | |
Modified megatestmod.scm
from [a70a654362]
to [5c7bd63407].
︙ | | |
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (uses pkts))
(declare (uses servermod))
(declare (uses fsmod))
(use srfi-69)
(module megatestmod
(
db:set-tests-state-status
db:set-state-status-and-roll-up-items
common:get-install-area
tests:get-all
common:use-cache?
*
mt:lazy-read-test-config
common:get-full-test-name
tests:extend-test-patts
tests:get-itemmaps
tests:get-items
tests:get-global-waitons
tests:get-tests-search-path
tests:filter-test-names
common:args-get-testpatt
tests:filter-test-names-not-matched
common:args-get-runname
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified monitor.scm
from [11b5fa345e]
to [d504b4ec3b].
︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
|
23
24
25
26
27
28
29
30
31
32
33
34
|
-
+
|
(declare (unit runs))
(declare (uses common))
(declare (uses runconfig))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
|
Modified mt.scm
from [f24a9e55ce]
to [a034bfff85].
︙ | | |
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
-
+
|
configfmod
rmtmod
megatestmod)
;; make mt: calls in megatestmod work
;; (read-config-set! read-config)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
|
︙ | | |
Modified mtexec.scm
from [8cf589213b]
to [e107d3437d].
︙ | | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
-
+
|
(declare (uses configfmod))
(import commonmod
configfmod
(prefix mtargs args:))
;; (use ducttape-lib)
(include "megatest-version.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (require-library stml)
(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
|
︙ | | |
Modified mtmod.scm
from [b742c926fe]
to [4d23e65eeb].
︙ | | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
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
|
+
+
+
+
+
+
+
-
+
+
+
+
+
|
(declare (uses commonmod))
(declare (uses configfmod))
;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp
(use srfi-69)
(module mtmod
(
keys:make-key/field-string
common:get-testsuite-name
items:get-items-from-config
mt:run-trigger
common:get-linktree
common:get-area-name
*
items:check-valid-items
mt:discard-blocked-tests
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified odsmod.scm
from [9072959ec4]
to [65e4e62b3c].
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
-
+
+
|
(declare (uses common))
(declare (uses commonmod))
(declare (uses debugprint))
(declare (uses dbfile))
(declare (uses dbmod))
(module odsmod
*
(
)
(import scheme
chicken
data-structures
extras
posix
ports
|
︙ | | |
Modified processmod.scm
from [1cce7c0878]
to [1199556817].
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
+
+
+
+
+
-
+
+
+
+
|
(declare (unit processmod))
(declare (uses debugprint))
(declare (uses commonmod))
(use srfi-69)
(module processmod
(
process:cmd-run->list
process:alive?
run-n-wait
process:cmd-run-with-stderr-and-exitcode->list
*
process:alive-on-host?
process:get-sub-pids
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified rmtmod.scm
from [f16c2416fe]
to [34cdc62311].
︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
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
152
|
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (uses dbmod))
(declare (uses mtmod))
(declare (uses tcp-transportmod))
(declare (uses apimod))
(declare (uses servermod))
(module rmtmod
(
rmtmod:send-receive
rmt:no-sync-get-lock
rmt:no-sync-del!
rmt:no-sync-set
rmt:no-sync-get/default
*
rmt:get-runs-by-patt
rmt:get-testinfo-state-status
rmt:get-test-id
rmt:set-state-status-and-roll-up-items
rmt:get-prereqs-not-met
rmt:get-tests-for-run
rmt:get-keys
rmt:test-get-records-for-index-file
tests:test-set-toplog!
rmt:test-get-logfile-info
rmt:general-call
rmt:test-get-paths-matching-keynames-target-new
rmt:get-test-info-by-id
rmt:get-steps-for-test
rmt:get-num-runs
rmt:get-runs-cnt-by-patt
rmt:get-runs
rmt:get-latest-host-load
rmt:get-changed-record-test-ids
rmt:get-all-runids
rmt:get-changed-record-run-ids
rmt:get-run-record-ids
rmt:get-data-info-by-id
rmt:get-steps-info-by-id
rmt:get-target
rmt:get-run-name-from-id
rmt:get-run-info
rmt:get-test-times
rmt:get-run-times
rmt:tasks-find-task-queue-records
common:api-changed?
rmt:on-homehost?
rmt:get-var
rmt:csv->test-data
rmt:get-previous-test-run-record
common:cleanup-db
common:get-last-run-version
rmt:get-key-val-pairs
rmt:create-all-triggers
rmt:update-tesdata-on-repilcate-db
rmt:drop-all-triggers
rmt:test-get-archive-block-info
rmt:test-toplevel-num-items
rmt:archive-get-allocations
rmt:archive-register-disk
rmt:archive-register-block-name
mt:get-runs-by-patt
rmt:simple-get-runs
rmt:get-tests-for-runs-mindata
rmt:test-get-top-process-pid
rmt:set-state-status-and-roll-up-run
rmt:get-run-state-status
rmt:get-not-completed-cnt
rmt:get-tests-tags
rmt:testmeta-update-field
rmt:testmeta-add-record
rmt:testmeta-get-record
rmt:lock/unlock-run
rmt:delete-old-deleted-test-records
rmt:delete-run
rmt:get-raw-run-stats
rmt:update-run-stats
rmt:delete-test-records
rmt:test-set-archive-block-id
mt:get-tests-for-run
mt:test-set-state-status-by-testname
mt:test-set-state-status-by-testname-unless-completed
rmt:register-test
mt:test-set-state-status-by-id-unless-completed
rmt:get-all-run-ids
rmt:set-run-state-status
rmt:set-var
rmt:set-tests-state-status
rmt:tasks-add
rmt:tasks-set-state-given-param-key
rmt:register-run
rmt:get-count-tests-running-in-jobgroup
rmt:get-count-tests-running-for-run-id
rmt:test-set-state-status-by-id
mt:test-set-state-status-by-id
rmt:get-status-from-final-status-file
rmt:get-toplevels-and-incompletes
rmt:test-set-log!
rmt:teststep-set-status!
rmt:delete-steps-for-test!
rmt:test-set-state-status
rmt:get-test-state-status-by-id
rmt:test-set-top-process-pid
)
(import scheme
chicken
data-structures
regex
extras
matchable
|
︙ | | |
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
|
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
|
-
-
-
-
+
+
+
+
|
(define (rmt:update-run-event_time run-id)
(assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
(rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
(assert (number? run-id) "FATAL: Run id required.")
;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
(rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
;; (define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
;; (assert (number? run-id) "FATAL: Run id required.")
;; ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
;; (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
(define (rmt:get-main-run-stats run-id)
(assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-main-run-stats #f (list run-id)))
(define (rmt:get-var varname)
(rmt:send-receive 'get-var #f (list varname)))
|
︙ | | |
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
|
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
|
-
-
-
-
-
+
+
+
+
+
|
(rmt:send-receive 'add-var #f (list varname value)))
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
;; Need to move this to multi-run section and make associated changes
(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
(let ((run-ids (rmt:get-all-run-ids)))
(for-each (lambda (run-id)
(rmt:find-and-mark-incomplete run-id ovr-deadtime))
run-ids)))
;; (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
;; (let ((run-ids (rmt:get-all-run-ids)))
;; (for-each (lambda (run-id)
;; (rmt:find-and-mark-incomplete run-id ovr-deadtime))
;; run-ids)))
;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;;
;; Run this at the client end since we have to connect to multiple run-id dbs
;;
(define (rmt:get-previous-test-run-record run-id test-name item-path)
|
︙ | | |
Modified runconfig.scm
from [5664220be3]
to [4f3ecb1f38].
︙ | | |
26
27
28
29
30
31
32
33
34
|
26
27
28
29
30
31
32
33
34
|
-
+
|
(declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(import commonmod
debugprint)
(include "common_records.scm")
;; (include "common_records.scm")
|
Modified runs.scm
from [647460790c]
to [5b967ec7eb].
︙ | | |
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
-
+
|
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format sxml-serializer
sxml-modifications matchable)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
;; (include "debugger.scm")
|
︙ | | |
Modified runsmod.scm
from [251bedfaeb]
to [2e2fa19e43].
︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
+
+
+
+
+
-
+
+
+
+
+
|
(declare (uses subrunmod))
(declare (uses archivemod))
(declare (uses fsmod))
(use srfi-69)
(module runsmod
(
rmt:find-and-mark-incomplete
launch:setup
launch:end-of-run-check
launch:test-copy
*
set-item-env-vars
runs:set-megatest-env-vars
full-runconfigs-read
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
-
+
|
tasksmod
testsmod
subrunmod
archivemod
fsmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
;; use this struct to facilitate refactoring
;;
|
︙ | | |
4538
4539
4540
4541
4542
4543
4544
4545
4546
|
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
|
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(if (member (symbol->string archive-command) '("save-remove"))
(begin
(debug:print-info 0 *default-log-port* "remove testdat")
(runs:remove-test-directory test-dat 'archive-remove)))))
(hash-table-ref test-groups test-base)))))
(hash-table-keys disk-groups))
#t))
;;======================================================================
;; Maintenance
;;======================================================================
)
(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
(let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
(test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
(rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)))
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
;;
;; NOT EASY TO MIGRATE TO db{file,mod}
;;
(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
;; The default running-deadtime is 720 seconds = 12 minutes.
;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
(deadtime-trim (or ovr-deadtime cfg-deadtime))
(server-start-allowance 200)
(server-overloaded-budget 200)
(launch-monitor-off-time (or test-stats-update-period 30))
(launch-monitor-on-time-budget 30)
(launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
(remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
(remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
(running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
(debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
(debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
(let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)))
(set! oldlaunched (list-ref dat 1))
(set! toplevels (list-ref dat 2))
(set! incompleted (list-ref dat 0)))
(debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
(length toplevels) " old LAUNCHED toplevel tests and "
(length incompleted) " tests marked RUNNING but apparently dead.")
;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
;;
;; (db:delay-if-busy dbdat)
(let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
(all-ids (append min-incompleted-ids (map car oldlaunched))))
(if (> (length all-ids) 0)
(begin
;; (launch:is-test-alive "localhost" 435)
(debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
" as DEAD")
(for-each
(lambda (test-id)
(let* ((tinfo (rmt:get-test-info-by-id run-id test-id))
(run-dir (db:test-get-rundir tinfo))
(host (db:test-get-host tinfo))
(pid (db:test-get-process_id tinfo))
(result (rmt:get-status-from-final-status-file run-dir)))
(if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result)))
(begin
(debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
(rmt:set-state-status-and-roll-up-items
run-id test-id 'foo "COMPLETED" "PASS"
"Test stopped responding but it has PASSED; marking it PASS in the DB."))
(let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored.
(commonmod:is-test-alive host pid))))
(if is-alive
(debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
" has a process on pid " pid ", NOT setting to DEAD.")
(begin
(debug:print 0 *default-log-port* "INFO: test " test-id
" final state/status is not COMPLETED/PASS. It is " result)
(rmt:set-state-status-and-roll-up-items
run-id test-id 'foo "COMPLETED" "DEAD"
"Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
;; call end of eud of run detection for posthook - from merge, is it needed?
;; (launch:end-of-run-check run-id)
all-ids)
)))))
)
|
Modified server.scm
from [3cd1085ec7]
to [6c3c9bb98f].
︙ | | |
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
-
+
|
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(import commonmod
configfmod
debugprint
(prefix mtargs args:))
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(define (db:kill-servers)
(let* ((tl (launch:setup)) ;; need this to initialize *toppath*
(servdir (conc *toppath* "/.servinfo"))
(servfiles (glob (conc servdir "/*:*.db")))
(fmtstr "~10a~22a~10a~25a~25a~8a\n")
|
︙ | | |
Modified servermod.scm
from [5384b281b4]
to [8f38f0674c].
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
+
+
+
+
-
+
+
|
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses mtmod))
(declare (uses debugprint))
(declare (uses mtargs))
(module servermod
(
remote-hh-dat
server:mk-signature
common:wait-for-normalized-load
*
)
(import scheme
chicken)
(use (srfi 18) extras s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(use directory-utils posix-extras matchable utils)
|
︙ | | |
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
-
+
|
commonmod
configfmod
debugprint
(prefix mtargs args:)
mtmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
|
︙ | | |
Modified subrunmod.scm
from [ddf54f1377]
to [f63d1179cd].
︙ | | |
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
-
+
+
+
+
+
+
+
+
+
+
|
(declare (uses mtmod))
(declare (uses megatestmod))
(declare (uses tasksmod))
(use srfi-69)
(module subrunmod
*
(
subrun:set-state-status
subrun:kill-subrun
subrun:get-log-path
subrun:remove-subrun
subrun:subrun-removed?
subrun:subrun-test-initialized?
subrun:launch-cmd
subrun:initialize-toprun-test
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified tasksmod.scm
from [381a26e6c2]
to [1d99e1d940].
︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
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
|
+
+
+
+
+
+
+
+
+
-
+
+
+
+
|
(declare (uses pgdb))
(declare (uses mtmod))
(declare (uses megatestmod))
(use srfi-69)
(module tasksmod
(
configf:write-alist
common:simple-unlock
common:simple-lock
tests:test-set-status!
common:get-launcher
tasks:kill-runner
tests:get-testconfig
tests:get-waitons
*
tests:get-test-path-from-environment
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
Modified tcmt.scm
from [114f35b4de]
to [fd7d43aafe].
︙ | | |
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
-
+
|
(use trace)
;; (trace-call-sites #t)
(import commonmod
rmtmod
(prefix mtargs args:))
(include "megatest-version.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (include "db_records.scm")
(define origargs (cdr (argv)))
(define remargs (args:get-args
(argv)
`( "-target"
|
︙ | | |
Modified tcp-transportmod.scm
from [1a862ecee9]
to [8cd3530dc9].
︙ | | |
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
43
44
45
46
47
48
49
50
|
-
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (uses dbmod))
(declare (uses portlogger))
(declare (uses mtmod))
(use address-info tcp)
(module tcp-transportmod
*
(
tt:mk-signature
tt-state
tt:server-process-run
tt:make-remote
tt-ro-mode-checked-set!
tt-ro-mode-set!
tt-ro-mode
tt-ro-mode-checked
tt:handler
tt:get-conn
)
(import scheme)
(cond-expand
(chicken-4
(import (prefix sqlite3 sqlite3:)
chicken
|
︙ | | |
Modified tdb.scm
from [e7e7aee13a]
to [536924ea4c].
︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
-
+
|
(import (prefix base64 base64:))
(import commonmod
debugprint
rmtmod
(prefix mtargs args:))
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
;;======================================================================
;;
;; T E S T D A T A B A S E S
|
︙ | | |
Modified test_records.scm
from [d106f3911c]
to [1501321c72].
︙ | | |
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
|
11
12
13
14
15
16
17
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; 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/>.
;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 7 #f))
(define (tests:testqueue-get-testname vec) (vector-ref vec 0))
(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
(define (tests:testqueue-get-waitons vec) (vector-ref vec 2))
(define (tests:testqueue-get-priority vec) (vector-ref vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define (tests:testqueue-get-items vec) (vector-ref vec 4))
(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
(define (tests:testqueue-get-item_path vec) (vector-ref vec 6))
(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
|
Modified testsmod.scm
from [342c5ad45d]
to [70de32f7f8].
︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
+
+
+
+
-
+
+
+
+
+
+
|
(declare (uses mtmod))
(declare (uses servermod))
(declare (uses fsmod))
(use srfi-69)
(module testsmod
(
tests:summarize-items
tests:filter-non-runnable
tests:sort-by-priority-and-waiton
*
tests:summarize-test
tests:save-final-status
tests:update-central-meta-info
tests:set-full-meta-info
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
|
︙ | | |
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
-
+
|
rmtmod
stml2
mtmod
servermod
fsmod
)
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
(include "js-path.scm")
(define (init-java-script-lib)
|
︙ | | |
Modified tree.scm
from [5b26f8b9f9]
to [ee0f2b29cf].
︙ | | |
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
-
-
+
+
|
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(import (prefix mtargs args:)
debugprint)
(include "megatest-version.scm")
(include "common_records.scm")
;; (include "megatest-version.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;;======================================================================
;; T R E E S T U F F
;;======================================================================
|
︙ | | |
Added utils/extract-export-list.sh version [d50045d1ff].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
|
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#!/bin/bash
LAST_PARENT=foobar
for fn in $(grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}');do
PARENT=$(grep $fn *mod.scm|grep define|cut -d: -f1)
if [[ $PARENT != $LAST_PARENT ]];then
echo
echo $PARENT
LAST_PARENT=$PARENT
fi
echo $fn
done
|
| | | | | | | | | | | |