| ︙ | | |
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
|
-
+
|
(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
(declare (uses hostinfo))
(declare (uses keysmod))
;; odd but it works?
(declare (uses itemsmod))
;; (declare (uses itemsmod))
(module commonmod
*
(import scheme
chicken.base
chicken.condition
|
| ︙ | | |
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
|
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
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
|
-
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
|
debugprint
stml2
pkts
processmod
(prefix mtargs args:)
configfmod
keysmod
itemsmod
;; itemsmod
hostinfo
)
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
;; testsuite and area utilites
;;
;;======================================================================
(include "megatest-fossil-hash.scm")
;;======================================================================
;; Make available the old db_records.scm stuff
;;======================================================================
;;
(include "db_records.scm")
;; (include "db_records.scm")
;;======================================================================
;; dbstruct
;;======================================================================
;;
;; -path-|-megatest.db
;; |-db-|-main.db
;; |-monitor.db
;; |-sdb.db
;; |-fdb.db
;; |-1.db
;; |-<N>.db
;;
;;
;; Accessors for a dbstruct
;;
;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path )
;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path )
;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2))
;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3))
;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path )
;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f )
;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6))
;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7))
;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8))
;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9))
;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path )
;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11))
;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path )
;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13))
;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14))
;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13))
;;
;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val))
;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val))
;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val))
;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val))
;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val))
;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val))
;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val))
;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val))
;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val))
;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val))
;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val))
;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val))
;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
;;
; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))
;; constructor for dbstruct
;;
;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
;; (let ((v (make-vector 15 #f)))
;; (dbr:dbstruct-path-set! v path)
;; (dbr:dbstruct-local-set! v local)
;; (dbr:dbstruct-locdbs-set! v (make-hash-table))
;; v))
(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) (conc #;printable (vector-ref vec 15)))
(define (db:test-get-first_warn vec) (conc #;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))
;;======================================================================
;; end of old db_records.scm
;;
;;======================================================================
;; old run_records stuff
;;
(define (runs:runrec-make-record) (make-vector 13))
(define (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c
(define (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string
(define (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d%
(define (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...)
(define (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...)
(define (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val
(define (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config
(define (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config
(define (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port)
(define (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http
(define (runs:runrec-db vec)(vector-ref vec 10)) ;; <sqlite3db> (if 'fs)
(define (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath*
(define (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id
(define (test:get-id vec) (vector-ref vec 0))
(define (test:get-run_id vec) (vector-ref vec 1))
(define (test:get-test-name vec)(vector-ref vec 2))
(define (test:get-state vec) (vector-ref vec 3))
(define (test:get-status vec) (vector-ref vec 4))
(define (test:get-item-path vec)(vector-ref vec 5))
(define (test:test-get-fullname test)
(conc (db:test-get-testname test)
(if (equal? (db:test-get-item-path test) "")
""
(conc "(" (db:test-get-item-path test) ")"))))
;;======================================================================
;; end of run_records
;;
;; these come from processmod
;;
;; (define setenv set-environment-variable!)
;; (define unsetenv unset-environment-variable!)
;; (define getenv get-environment-variable)
;; move all the miscellanea into this struct
;;
(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target)
(define *bdat* #f) ;; the one and only (someday) global?
(defstruct bdat
(home (getenv "HOME"))
(user (getenv "USER"))
(home (get-environment-variable "HOME"))
(user (get-environment-variable "USER"))
(watchdog #f)
(time-to-exit #f)
(task-db #f)
(target #f)
(this-exe-fullpath #f)
(this-exe-dir #f)
(this-exe-name #f)
|
| ︙ | | |
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
|
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
|
-
-
+
+
-
+
|
;; set up signal handlers
(set-signal-handler! signal/int std-signal-handler) ;; ^C
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
bdat))
;; (define home (getenv "HOME"))
;; (define user (getenv "USER"))
;; (define home (get-environment-variable "HOME"))
;; (define user (get-environment-variable "USER"))
(define keys:config-get-fields common:get-fields)
;; Globals
;;
;;(define *server-loop-heart-beat* (current-seconds))
;; (define *watchdog* #f)
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))
(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 ==> moved to configfmod
|
| ︙ | | |
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
|
+
-
-
-
|
(define *home-host* #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded* #f)
(define *writes-total-delay* 0)
(define *unclean-shutdown* #t) ;; flag to clear on clean shutdown
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
;; RPC transport
(define *rpc:listener* #f)
|
| ︙ | | |
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
|
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
|
-
+
-
-
+
+
|
(cons var (get-environment-variable var))))
variables)))
(dynamic-wind
(lambda () (void))
(lambda ()
;; (use posix)
(for-each (lambda (var-value)
(setenv (car var-value) (cdr var-value)))
(set-environment-variable! (car var-value) (cdr var-value)))
variables)
(thunk))
(lambda ()
(for-each (lambda (var-value)
(let ((var (car var-value))
(value (cdr var-value)))
(if value
(setenv var value)
(unsetenv var))))
(set-environment-variable! var value)
(unset-environment-variable! var))))
pre-existing-variables)))))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
|
| ︙ | | |
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
|
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
|
-
+
|
(if (> (- currtime lasttime) waitval)
(begin
(hash-table-set! *common:denoise* key currtime)
#t)
#f)))
(define (common:get-megatest-exe)
(or (getenv "MT_MEGATEST") "megatest"))
(or (get-environment-variable "MT_MEGATEST") "megatest"))
(define (common:read-encoded-string instr)
(handle-exceptions
exn
(handle-exceptions
exn
(begin
|
| ︙ | | |
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
|
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
|
-
+
-
+
-
+
-
+
|
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-area-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
(getenv "MT_TESTSUITE_NAME")
(get-environment-variable "MT_TESTSUITE_NAME")
(pathname-file (or (if (string? *toppath* )
(pathname-file *toppath*)
#f)
(common:get-toppath #f)))
"please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
;;======================================================================
;; safe getting of toppath
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
(begin
(set! *toppath* areapath)
(setenv "MT_RUN_AREA_HOME" areapath)
(set-environment-variable! "MT_RUN_AREA_HOME" areapath)
areapath)
#f)
(if (getenv "MT_RUN_AREA_HOME")
(if (get-environment-variable "MT_RUN_AREA_HOME")
(begin
(set! *toppath* (getenv "MT_RUN_AREA_HOME"))
(set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
*toppath*)
#f)
;; last resort, look for megatest.config
(let loop ((thepath (realpath ".")))
(if (file-exists? (conc thepath "/megatest.config"))
thepath
(if (equal? thepath "/")
|
| ︙ | | |
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
|
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
|
-
-
-
-
-
-
-
-
-
-
+
-
+
-
+
-
+
|
(target-patt (args:get-arg "-target")))
(if target-patt
(filter (lambda (x)
(patt-list-match x target-patt))
targs)
targs)))
;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config var)
(let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (configf:lookup config targ var)
(configf:lookup config "default" var))
(configf:lookup config "default" var))))
(let* (;; (tagexpr (args:get-arg "-tagexpr"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(rtestpatt (if rconf (runconfigs-get rconf target testpatt-key) #f)))
(cond
((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
(let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
(let* ((patts-from-mode-patt (runconfigs-get rconf target testpatt-key)))
(debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
patts-from-mode-patt)
(begin
(debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
#f))) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
|
| ︙ | | |
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
|
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
|
-
+
-
-
+
+
-
-
+
+
-
+
|
#f)
(if (and (directory-exists? path-string)
(file-writable? path-string))
path-string
#f)))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(or (get-environment-variable "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
#f)
(if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
(conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
(if (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
(conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) "/lt")
#f)
(let* ((tp (common:get-toppath #f))
(lt (conc tp "/lt")))
(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
lt)))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
(get-environment-variable "MT_RUNNAME"))))
;; (if res (set-environment-variable! "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(get-environment-variable "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
(null? (filter string-null? tlist))))
#f)))
|
| ︙ | | |
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
|
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
|
-
-
-
-
-
+
+
+
+
+
-
-
+
+
-
+
|
#f)
#f))))
;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
(if (and (getenv "MT_ITEMPATH")
(not (equal? (getenv "MT_ITEMPATH") "")))
(getenv "MT_TEST_NAME")
(conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
(if (get-environment-variable "MT_TEST_NAME")
(if (and (get-environment-variable "MT_ITEMPATH")
(not (equal? (get-environment-variable "MT_ITEMPATH") "")))
(get-environment-variable "MT_TEST_NAME")
(conc (get-environment-variable "MT_TEST_NAME") "/" (get-environment-variable "MT_ITEMPATH")))
#f))
;;======================================================================
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(let ((res #t)) ;; priority by order of evaluation
(if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
(if (getenv "MT_USE_CACHE")
(if (equal? (getenv "MT_USE_CACHE") "yes")
(if (get-environment-variable "MT_USE_CACHE")
(if (equal? (get-environment-variable "MT_USE_CACHE") "yes")
(set! res #t)
(if (equal? (getenv "MT_USE_CACHE") "no")
(if (equal? (get-environment-variable "MT_USE_CACHE") "no")
(set! res #f)))) ;; overrides -no-cache switch
res))
;;======================================================================
;; force use of server?
;;
(define (common:force-server?)
|
| ︙ | | |
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
|
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
|
-
+
-
+
-
-
+
+
|
;; server process management
;;======================================================================
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
(setenv "TARGETHOST" hostname)
(set-environment-variable! "TARGETHOST" hostname)
(let* ((logdir (if (directory-exists? "logs")
"logs/"
""))
(logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
(gzfile (if logfile (conc logfile ".gz"))))
(setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
(set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
(system (conc "nbfake kill "kill-switch" "pid))
(when logfile
(thread-sleep! 0.5)
(if (file-exists? gzfile) (delete-file gzfile))
(system (conc "gzip " logfile))
(unsetenv "TARGETHOST_LOGF")
(unsetenv "TARGETHOST"))))
(unset-environment-variable! "TARGETHOST_LOGF")
(unset-environment-variable! "TARGETHOST"))))
(define (server:get-logs-list area-path)
(let* (;; (server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log"))
;; (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))
(server-logs (glob (conc area-path"/logs/server-*-*.log")))
)
server-logs))
|
| ︙ | | |
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
|
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
|
-
+
|
(for-each (lambda (p)
(let* ((var (car p))
(val (cadr p))
(prv (get-environment-variable var)))
(set! res (cons (list var prv) res))
(if val
(safe-setenv var (->string val))
(unsetenv var))))
(unset-environment-variable! var))))
lst)
res)
'()))
;;======================================================================
;; clear vars matching pattern, run proc, set vars back
;; if proc is a string run that string as a command with
|
| ︙ | | |
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
|
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
|
-
-
+
+
-
-
+
+
-
+
-
+
|
(if (string-match "^MT_.*" (car x))
#f
x))
envvars))))
(define (common:with-orig-env proc)
(let ((current-env (get-environment-variables)))
(for-each (lambda (x) (unsetenv (car x))) current-env)
(for-each (lambda (x) (setenv (car x) (cdr x))) (bdat-orig-env *bdat*))
(for-each (lambda (x) (unset-environment-variable! (car x))) current-env)
(for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) (bdat-orig-env *bdat*))
(let ((rv (cond
((string? proc)(system proc))
(proc (proc)))))
(for-each (lambda (x) (unsetenv (car x))) (bdat-orig-env *bdat*))
(for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
(for-each (lambda (x) (unset-environment-variable! (car x))) (bdat-orig-env *bdat*))
(for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env)
rv)))
(define (common:without-vars proc . var-patts)
(let ((vars (make-hash-table)))
(for-each
(lambda (vardat) ;; each env var
(for-each
(lambda (var-patt)
(if (string-match var-patt (car vardat))
(let ((var (car vardat))
(val (cdr vardat)))
(hash-table-set! vars var val)
(unsetenv var))))
(unset-environment-variable! var))))
var-patts))
(get-environment-variables))
(cond
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
(set-environment-variable! var val)))
vars))
(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
(let* ((pre-cmd (dtests:get-pre-command))
(post-cmd (dtests:get-post-command))
(fullcmd (if (or pre-cmd post-cmd)
(conc pre-cmd cmd post-cmd)
|
| ︙ | | |
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
|
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(cond
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
;; return items given config
;;
(define (tests:get-items tconfig)
(let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
(itemstable (hash-table-ref/default tconfig "itemstable" #f)))
;; if either items or items table is a proc return it so test running
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
;; otherwise return #f - this is not an iterated test
(cond
((procedure? items)
(debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
items) ;; calc later
((procedure? itemstable)
(debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
itemstable) ;; calc later
((filter (lambda (x)
(let ((val (car x)))
(if (procedure? val) val #f)))
(append (if (list? items) items '())
(if (list? itemstable) itemstable '())))
'have-procedure)
((or (list? items)(list? itemstable)) ;; calc now
(debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
" items: " items " itemstable: " itemstable)
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
|
| ︙ | | |
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
|
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
|
-
+
|
;; timeout is hms string: 1h 5m 3s, default is 10 minutes
;;
(define (server:expiration-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
(* 3600 (string->number tmo))
600))) ;; default is ten minutes
60))) ;; default is one minute
(define (runs:get-mt-env-alist run-id runname target testname itempath)
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
`(("MT_TEST_NAME" . ,testname)
("MT_ITEMPATH" . ,itempath)
|
| ︙ | | |