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
|
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
(server:launch))
(define *logged-in-clients* (make-hash-table))
(if (or (args:get-arg "-listservers")
(args:get-arg "-killserver"))
(let ((tl (setup-for-run)))
(if tl
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~8a~20a~5a~20a~8a~10a\n"))
(format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State")
(format #t fmtstr "==" "===" "====" "====" "====" "========" "=====")
(for-each
(lambda (server)
(let* ((id (vector-ref server 0))
(pid (vector-ref server 1))
(hostname (vector-ref server 2))
(port (vector-ref server 3))
(start-time (vector-ref server 4))
(priority (vector-ref server 5))
(state (vector-ref server 6))
(accessible (handle-exceptions
exn
#f
(let ((zmq-socket (server:client-login hostname port)))
(if zmq-socket
(server:client-logout zmq-socket)
#f)))))
(format #t fmtstr id pid hostname port start-time priority
(cond
(accessible "ACCESSIBLE")
(else "DEAD")))))
servers)))))
(if (or (let ((res #f))
(for-each
(lambda (key)
(if (args:get-arg key)(set! res #t)))
(list "-h" "-version" "-gen-megatest-area" "-gen-megatest-test"))
res)
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "No server needed")
(server:client-launch))
;;======================================================================
;; Remove old run(s)
;;======================================================================
;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)
|
>
>
|
<
<
|
|
<
>
|
>
>
|
>
>
>
>
>
|
<
<
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
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
|
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
(begin
(debug:print 1 "Launching server...")
(server:launch)))
(if (or (args:get-arg "-listservers")
(args:get-arg "-killserver"))
(let ((tl (setup-for-run)))
(if tl
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~8a~20a~5a~20a~9a~10a\n"))
(format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State")
(format #t fmtstr "==" "===" "====" "====" "====" "========" "=====")
(for-each
(lambda (server)
(let* ((id (vector-ref server 0))
(pid (vector-ref server 1))
(hostname (vector-ref server 2))
(port (vector-ref server 3))
(start-time (vector-ref server 4))
(priority (vector-ref server 5))
(state (vector-ref server 6))
(status (handle-exceptions
exn
(conc "EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(let ((zmq-socket (server:client-connect hostname port)))
(if zmq-socket
(if (server:client-login zmq-socket)
(begin
(server:client-logout zmq-socket)
(close-socket zmq-socket)
"ACCESSIBLE") ;; (server:client-logout zmq-socket)
(begin
(close-socket zmq-socket)
"CAN'T LOGIN"))
"CAN'T CONNECT")))))
(format #t fmtstr id pid hostname port start-time priority
status)))
servers)
(set! *didsomething* #t))))
;; if not list or kill then start a client (if appropriate)
(if (or (let ((res #f))
(for-each
(lambda (key)
(if (args:get-arg key)(set! res #t)))
(list "-h" "-version" "-gen-megatest-area" "-gen-megatest-test"))
res)
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
(server:client-launch)))
;;======================================================================
;; Remove old run(s)
;;======================================================================
;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)
|