︙ | | | ︙ | |
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
|
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
(if (and (not (null? remargs))
(not (or
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
)
;; add more args that use remargs here
))
(debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
(if targ (setenv "MT_TARGET" targ)))
|
>
>
<
|
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
|
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
;; Add args that use remargs here
;;
(if (and (not (null? remargs))
(not (or
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
)
))
(debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
(if targ (setenv "MT_TARGET" targ)))
|
︙ | | | ︙ | |
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
|
;; (set! *did-something* #t)
;; (begin
;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
;; (case (server:get-transport)
;; ((http)(http:ping run-id host-port))
;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port)))
;; (else (debug:print 0 "ERROR: No transport set")(exit)))))
;;======================================================================
;; 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? Start up here.
;;
(let ((tl (launch:setup-for-run))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(if run-id
(begin
(server:launch run-id)
(set! *didsomething* #t))
(debug:print 0 "ERROR: server requires run-id be specified with -run-id"))))
;; 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"
;; "-list-runs"
;; "-ping")))
;; (if (launch:setup-for-run)
;; (let ((run-id (and (args:get-arg "-run-id")
;; (string->number (args:get-arg "-run-id")))))
;; ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; ;; 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")
;; (begin
;; ;; (if run-id
;; ;; (client:launch run-id)
;; ;; (client:launch 0) ;; without run-id we'll start a server for "0"
;; #t
;; ))))))
;; MAY STILL NEED THIS
;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (launch:setup-for-run)))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
|
;; (set! *did-something* #t)
;; (begin
;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
;; (case (server:get-transport)
;; ((http)(http:ping run-id host-port))
;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port)))
;; (else (debug:print 0 "ERROR: No transport set")(exit)))))
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
;; NOTE: Keep these above the section where the server or client code is setup
(let ((envcap (args:get-arg "-envcap")))
(if envcap
(let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
(env:save-env-vars db envcap)
(env:close-database db)
(set! *didsomething* #t))))
;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b
;;
(let ((envdelta (args:get-arg "-envdelta")))
(if envdelta
(let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
(if (not (null? match))
(let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
;; (resctx (cadr match))
;; (equn (caddr match))
(parts match) ;; (string-split equn "-"))
(minuend (car parts))
(subtraend (cadr parts))
(added (env:get-added db minuend subtraend))
(removed (env:get-removed db minuend subtraend))
(changed (env:get-changed db minuend subtraend)))
;; (pp (hash-table->alist added))
;; (pp (hash-table->alist removed))
;; (pp (hash-table->alist changed))
(if (args:get-arg "-o")
(with-output-to-file
(args:get-arg "-o")
(lambda ()
(env:print added removed changed)))
(env:print added removed changed))
(env:close-database db)
(set! *didsomething* #t))
(debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end")))))
;;======================================================================
;; 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? Start up here.
;;
(let ((tl (launch:setup-for-run))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(if run-id
(begin
(server:launch run-id)
(set! *didsomething* #t))
(debug:print 0 "ERROR: server requires run-id be specified with -run-id")))
;; 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"
"-list-runs"
"-ping")))
(if (launch:setup-for-run)
(let ((run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; 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")
(begin
;; (if run-id
;; (client:launch run-id)
;; (client:launch 0) ;; without run-id we'll start a server for "0"
#t
))))))
;; MAY STILL NEED THIS
;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (launch:setup-for-run)))
|
︙ | | | ︙ | |
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
|
targets))
((json)
(json-write targets))
(else
(debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(set! *didsomething* #t)))
(define (full-runconfigs-read)
(let* ((keys (rmt:get-keys))
(target (common:args-get-target))
(key-vals (if target (keys:target->keyval keys target) #f))
(sections (if target (list "default" target) #f))
(data (begin
(setenv "MT_RUN_AREA_HOME" *toppath*)
(if key-vals
(for-each (lambda (kt)
(setenv (car kt) (cadr kt)))
key-vals))
(read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
data))
(if (args:get-arg "-show-runconfig")
(let ((tl (launch:setup-for-run)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
;; keep this one local
(cond
|
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
|
<
|
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
|
targets))
((json)
(json-write targets))
(else
(debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(set! *didsomething* #t)))
;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
(let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
#f))
(cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
(if (and cfgf
(file-exists? cfgf)
(file-write-access? cfgf))
(configf:read-alist cfgf)
(let* ((keys (rmt:get-keys))
(target (common:args-get-target))
(key-vals (if target (keys:target->keyval keys target) #f))
(sections (if target (list "default" target) #f))
(data (begin
(setenv "MT_RUN_AREA_HOME" *toppath*)
(if key-vals
(for-each (lambda (kt)
(setenv (car kt) (cadr kt)))
key-vals))
(read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
(if (and rundir ;; have all needed variabless
(directory-exists? rundir)
(file-write-access? rundir))
(begin
(configf:write-alist data cfgf)
;; force re-read of megatest.config - this resolves circular references between megatest.config
(launch:setup-for-run force: #t)
(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
data))))
(if (args:get-arg "-show-runconfig")
(let ((tl (launch:setup-for-run)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
;; keep this one local
(cond
|
︙ | | | ︙ | |
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
|
(begin
(db:multi-db-sync
#f ;; do all run-ids
'new2old
)
(set! *didsomething* #t)))
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
(let ((envcap (args:get-arg "-envcap")))
(if envcap
(let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
(env:save-env-vars db envcap)
(env:close-database db)
(set! *didsomething* #t))))
;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b
;;
(let ((envdelta (args:get-arg "-envdelta")))
(if envdelta
(let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
(if (not (null? match))
(let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
;; (resctx (cadr match))
;; (equn (caddr match))
(parts match) ;; (string-split equn "-"))
(minuend (car parts))
(subtraend (cadr parts))
(added (env:get-added db minuend subtraend))
(removed (env:get-removed db minuend subtraend))
(changed (env:get-changed db minuend subtraend)))
;; (pp (hash-table->alist added))
;; (pp (hash-table->alist removed))
;; (pp (hash-table->alist changed))
(if (args:get-arg "-o")
(with-output-to-file
(args:get-arg "-o")
(lambda ()
(env:print added removed changed)))
(env:print added removed changed))
(env:close-database db)
(set! *didsomething* #t))
(debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end")))))
;;======================================================================
;; Exit and clean up
;;======================================================================
(if *runremote* (close-all-connections!))
(if (not *didsomething*)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
|
(begin
(db:multi-db-sync
#f ;; do all run-ids
'new2old
)
(set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
;;======================================================================
(if *runremote* (close-all-connections!))
(if (not *didsomething*)
|
︙ | | | ︙ | |