33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
(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)
|
|
>
>
>
|
|
>
>
>
>
|
|
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
|
(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
path
transport
configinfo
configdat
denoise
client-signature
remote
)
(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
|
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
(define *db-write-access* #t)
(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>
(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)
|
|
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
(define *db-write-access* #t)
(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)
|
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
|
(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)
(debug:print-info 2 "starting exit process, finalizing databases.")
(rmt:print-db-stats)
(let ((run-ids (hash-table-keys *db-local-sync*)))
(configf:lookup *configdat* "setup" "megatest-db"))
(db:multi-db-sync run-ids 'new2old)))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *inmemdb* (db:close-all *inmemdb*))
(if (and *megatest-db*
(sqlite3:database? *megatest-db*))
(begin
(sqlite3:interrupt! *megatest-db*)
|
|
|
|
|
|
>
|
|
|
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
|
(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)
(debug:print-info 2 "starting exit process, finalizing databases.")
(rmt:print-db-stats area-dat)
(let* ((configdat (megatest:area-configdat area-dat))
(run-ids (hash-table-keys *db-local-sync*)))
(if (and (not (null? run-ids))
(configf:lookup configdat "setup" "megatest-db"))
(db:multi-db-sync run-ids 'new2old)))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *inmemdb* (db:close-all *inmemdb*))
(if (and *megatest-db*
(sqlite3:database? *megatest-db*))
(begin
(sqlite3:interrupt! *megatest-db*)
|