| ︙ | | | ︙ | |
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
(begin
(print megatest-version)
(exit)))
(define *didsomething* #f)
;; Force default transport to fs
(if ;; (and (or (args:get-arg "-list-targets")
;; (args:get-arg "-list-db-targets"))
(not (args:get-arg "-transport"))
(hash-table-set! args:arg-hash "-transport" "fs"))
;;======================================================================
;; Misc setup stuff
;;======================================================================
(debug:setup)
|
|
|
|
|
|
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
(begin
(print megatest-version)
(exit)))
(define *didsomething* #f)
;; Force default transport to fs
;; (if ;; (and (or (args:get-arg "-list-targets")
;; ;; (args:get-arg "-list-db-targets"))
;; (not (args:get-arg "-transport"))
;; (hash-table-set! args:arg-hash "-transport" "fs"))
;;======================================================================
;; Misc setup stuff
;;======================================================================
(debug:setup)
|
| ︙ | | | ︙ | |
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
|
(transport (or (configf:lookup *configdat* "setup" "transport")
(args:get-arg "-transport" "http"))))
(debug:print 2 "Launching server using transport " transport)
(server:launch (string->symbol transport)))
;; Not a server? This section will decide how to communicate
;;
(if (not (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-runtests" "-list-runs" "-rollup"
"-remove-runs" "-lock" "-unlock"
"-update-meta" "-extract-ods" "-list-servers"
"-stop-server" "-show-cmdinfo"))))
(let ((transport-from-config (configf:lookup *configdat* "setup" "transport"))
(transport-from-cmdln (args:get-arg "-transport"))
(transport-from-cmdinfo (if (getenv "MT_CMDINFO")
(assoc 'transport
(read (open-input-string (base64:base64-decode
(getenv "MT_CMDINFO")))))
#f)))
(cond
;; command line overrides other mechanisms
(transport-from-cmdln
(if (equal? transport-from-cmdln "fs")
(set! *transport-type* 'fs)
(begin
(server:ensure-running)
(client:launch))))
;; cmdinfo is second priority
(transport-from-cmdinfo
(if (equal? transport-from-cmdinfo "fs")
(set! *transport-type* 'fs)
(begin
(server:ensure-running)
(client:launch))))
;; config file is next highest priority for determinining transport
(transport-from-config
(if (equal? transport-from-config "fs")
(set! *transport-type* 'fs)
(begin
(server:ensure-running)
(client:launch))))
(else
(set! *transport-type* 'fs)))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (setup-for-run)))
(if tl
(let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
|
>
|
<
<
|
|
>
|
|
|
|
>
>
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
|
(transport (or (configf:lookup *configdat* "setup" "transport")
(args:get-arg "-transport" "http"))))
(debug:print 2 "Launching server using transport " transport)
(server:launch (string->symbol transport)))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-list-servers"
"-stop-server"
"-show-cmdinfo")))
(if (setup-for-run)
(begin
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
;; ok, so lets connect to the server
(let* ((transport-from-config (configf:lookup *configdat* "setup" "transport"))
(transport-from-cmdln (args:get-arg "-transport"))
(transport-from-cmdinfo (if (getenv "MT_CMDINFO")
(let ((res (assoc 'transport
(read
(open-input-string
(base64:base64-decode
(getenv "MT_CMDINFO")))))))
(if res (cadr res) #f))
#f))
(chosen-transport (string->symbol (or transport-from-cmdln
transport-from-cmdinfo
transport-from-config
"fs"))))
(debug:print 0 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
(case chosen-transport
((http)
(set! *transport-type 'http)
(server:ensure-running)
(client:launch))
(else ;; (fs)
(set! *transport-type* 'fs)
(set! *megatest-db* (open-db))))))))))
;; (cond
;; ;; command line overrides other mechanisms
;; (transport-from-cmdln
;; (if (equal? transport-from-cmdln "fs")
;; (set! *transport-type* 'fs)
;; (begin
;; (server:ensure-running)
;; (client:launch))))
;; ;; cmdinfo is second priority
;; (transport-from-cmdinfo
;; (if (equal? transport-from-cmdinfo "fs")
;; (set! *transport-type* 'fs)
;; (begin
;; (server:ensure-running)
;; (client:launch))))
;; ;; config file is next highest priority for determinining transport
;; (transport-from-config
;; (if (equal? transport-from-config "fs")
;; (set! *transport-type* 'fs)
;; (begin
;; (server:ensure-running)
;; (client:launch))))
;; (else
;; (set! *transport-type* 'fs)))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (setup-for-run)))
(if tl
(let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
|
| ︙ | | | ︙ | |
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
|
(db #f)
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target"))
(toppath (assoc/default 'toppath cmdinfo)))
(change-directory toppath)
;; (set! *runremote* runremote)
(set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
|
|
|
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
|
(db #f)
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target"))
(toppath (assoc/default 'toppath cmdinfo)))
(change-directory toppath)
;; (set! *runremote* runremote)
;; (set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
|
| ︙ | | | ︙ | |
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
|
(itemdat (assoc/default 'itemdat cmdinfo))
(db #f)
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target")))
(change-directory testpath)
;; (set! *runremote* runremote)
(set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
|
|
|
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
|
(itemdat (assoc/default 'itemdat cmdinfo))
(db #f)
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target")))
(change-directory testpath)
;; (set! *runremote* runremote)
;; (set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
|
| ︙ | | | ︙ | |
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
|
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
;; (set! *runremote* runremote)
(set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
;; DO NOT remote run, makes calls to the testdat.db test db.
(db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)
|
>
|
|
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
|
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
;; (set! *runremote* runremote)
;; The transport is handled earlier in the loading process of megatest.
;; (set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
;; DO NOT remote run, makes calls to the testdat.db test db.
(db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)
|
| ︙ | | | ︙ | |
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
|
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f) ;; (open-db))
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
;; (set! *runremote* runremote)
(set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
(change-directory work-area)
|
|
|
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
|
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f) ;; (open-db))
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
;; (set! *runremote* runremote)
;; (set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
(change-directory work-area)
|
| ︙ | | | ︙ | |