40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
(setenv key val))
(debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat* #f)
(define *toppath* #f)
|
|
>
>
>
|
|
>
>
>
>
>
>
>
|
|
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
|
(setenv key val))
(debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
(define-record megatest:area
name ;; area name
path ;; mt run area home
transport ;; defaults to http
configinfo ;; legacy config format
configdat ;; megatest config
denoise ;; focal point for not
client-signature ;; key for client-server conversation
remote ;; hash of all the client side connnections
run-keys ;; target keys for this area
runs ;; used in dashboard
read-only ;; can I write to this area?
)
(define *already-seen-runconfig-info* #f)
(define *waiting-queue* (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f) ;; used by -log
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
(define *inmemdb* #f)
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
|
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
(define *inmemdb* #f)
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
;; SERVER
(define *my-client-signature* #f)
;; (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
;; (define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
(define (common:get-remote remote run-id)
(let ((ht (or remote *runremote*)))
(if ht
(hash-table-ref/default ht run-id #f)
#f)))
(define (common:set-remote! remote run-id value)
(let ((ht (or remote *runremote*)))
(if ht
(hash-table-set! ht run-id value))))
(define (common:del-remote! remote run-id)
(let ((ht (or remote *runremote*)))
(if ht
(hash-table-delete! ht run-id))))
(define (common:get-remote-all remote)
(let ((ht (or remote *runremote*)))
(if ht
(hash-table-keys ht)
'())))
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *received-response* #f)
|
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
|
(let ((val (args:get-arg val)))
(if val val default)))
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "testsuite" )
(pathname-file *toppath*)))
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (std-exit-procedure)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(let ((run-ids (hash-table-keys *db-local-sync*)))
(if (and (not (null? run-ids))
(configf:lookup *configdat* "setup" "megatest-db"))
(if no-hurry (db:multi-db-sync run-ids 'new2old))))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *inmemdb* (db:close-all *inmemdb*))
|
|
|
|
|
|
|
>
>
|
<
|
|
|
|
|
|
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
|
(let ((val (args:get-arg val)))
(if val val default)))
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name area-dat)
(or (configf:lookup (megatest:area-configdat area-dat) "setup" "testsuite" )
(pathname-file (megatest:area-path area-dat))))
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (std-exit-procedure area-dat)
(let* ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t)))
(configdat (megatest:area-configdat area-dat))
(run-ids (hash-table-keys *db-local-sync*)))
(debug:print-info 4 "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats area-dat))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(if (and (not (null? run-ids))
(configf:lookup configdat "setup" "megatest-db"))
(if no-hurry (db:multi-db-sync run-ids 'new2old)))
(if *dbstruct-db* (db:close-all *dbstruct-db* area-dat))
(if *inmemdb* (db:close-all *inmemdb* area-dat))
(if (and *megatest-db*
(sqlite3:database? *megatest-db*))
(begin
(sqlite3:interrupt! *megatest-db*)
(sqlite3:finalize! *megatest-db* #t)
(set! *megatest-db* #f)))
(if *task-db*
|