Overview
Context
Changes
Modified common.scm
from [f2d9dfe4a2]
to [76c8878689].
︙ | | |
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
|
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
|
-
+
|
(cdr hh)
#f)))
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(let ((res #t)) ;; priority by order of evaluation
(if *configdat*
(if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
(if (getenv "MT_USE_CACHE")
(if (equal? (getenv "MT_USE_CACHE") "yes")
|
︙ | | |
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
|
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
|
-
-
+
+
+
+
+
+
-
+
|
(string-intersperse
(map (lambda (x)
(number->string x 16))
(map string->number
(string-split instr)))
"/"))
(define (common:faux-lock keyname #!key (wait-time 5))
(if (rmt:no-sync-get/default keyname #f)
(define (common:faux-lock keyname #!key (wait-time 8))
(if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
(if (> wait-time 0)
(begin
(thread-sleep! 1)
(if (eq? wait-time 1) ;; only one second left, steal the lock
(begin
(debug:print-info 0 *default-log-port* "stealing lock for " keyname)
(common:faux-unlock keyname force: #t)))
(common:faux-lock keyname wait-time: (- wait-time 1)))
#f)
(begin
(rmt:no-sync-set keyname (conc (current-process-id)))
(equal? (conc (current-process-id)) (conc (rmt:get-var keyname))))))
(equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))))
(define (common:faux-unlock keyname #!key (force #f))
(if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))
(begin
(if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
#t)
#f))
|
︙ | | |
Modified launch.scm
from [3b1eca98b3]
to [e8bd32c72b].
︙ | | |
758
759
760
761
762
763
764
765
766
767
768
769
770
771
|
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
|
+
+
|
(mutex-unlock! m)
(debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(if (not (launch:einf-exit-status exit-info))
(exit 4))))
)))
;; DO NOT USE - caching of configs is handled in launch:setup now.
;;
(define (launch:cache-config)
;; if we have a linktree and -runtests and -target and the directory exists dump the config
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
(if (and *configdat*
(or (args:get-arg "-run")
(args:get-arg "-runtests")
(args:get-arg "-execute")))
|
︙ | | |
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
|
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
|
+
+
+
-
+
+
+
+
+
+
-
+
|
#f
(cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
(set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
;;(BB> "launch:setup-body -- cachefiles="cachefiles)
(cond
;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
((and (not force-reread)
mtcachef rccachef
use-cache
((and (not force-reread) mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
(get-environment-variable "MT_RUN_AREA_HOME")
(common:file-exists? mtcachef)
(common:file-exists? rccachef))
;;(BB> "launch:setup-body -- cond branch 1 - use-cache")
(set! *configdat* (configf:read-alist mtcachef))
;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*)
(set! *runconfigdat* (configf:read-alist rccachef))
(set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
(set! *configstatus* 'fulldata)
(set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
*toppath*)
;; there are no existing cached configs, do full reads of the configs and cache them
;; we have all the info needed to fully process runconfigs and megatest.config
((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it?
mtcachef
((and (not force-reread) mtcachef) ;; BB- why are we doing this without asking if caching is desired?
rccachef) ;; BB- why are we doing this without asking if caching is desired?
;;(BB> "launch:setup-body -- cond branch 2")
(let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(first-rundat (let ((toppath (if toppath
|
︙ | | |
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
|
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
|
-
+
-
-
-
+
+
+
-
+
+
+
|
key-vals)
(read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
sections: sections)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
(if rccachef (configf:write-alist runconfigdat rccachef))
(set! *runconfigdat* runconfigdat)
(if mtcachef (configf:write-alist *configdat* mtcachef))
(set! *runconfigdat* runconfigdat)
(if (and rccachef mtcachef) (set! *configstatus* 'fulldata))))
;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
(begin (set! *configdat* (make-hash-table))
;;(BB> "launch:setup-body -- 3 set! *configdat*="*configdat*)
)
(set! *configdat* (make-hash-table))
)))
)))
;; else read what you can and set the flag accordingly
;; here we don't have either mtconfig or rccachef
(else
;;(BB> "launch:setup-body -- cond branch 3 - else")
(let* ((cfgdat (find-and-read-config
(or (args:get-arg "-config") "megatest.config")
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME")))
(if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
(let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
(rdat (read-config (conc toppath ;; convert this to use runconfig:read!
"/runconfigs.config") *runconfigdat* #t sections: sections)))
(set! *configinfo* cfgdat)
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* toppath)
(set! *configstatus* 'partial))
(begin
(debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
(exit 2))))))
;; COND ends here.
;; additional house keeping
(let* ((linktree (common:get-linktree)))
(if linktree
(begin
(if (not (common:file-exists? linktree))
(begin
(handle-exceptions
|
︙ | | |
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
|
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
|
-
-
-
+
+
|
(if (and *toppath*
(directory-exists? *toppath*))
(begin
(setenv "MT_RUN_AREA_HOME" *toppath*)
(setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
(begin
(debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
;;(exit 1)
(set! *toppath* #f) ;; force it to be false so we return #f
#f
))
#f))
;; one more attempt to cache the configs for future reading
(let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
(if (and rccachef *runconfigdat* (not (file-exists? rccachef))) (configf:write-alist *runconfigdat* rccachef))
(if (and mtcachef *configdat* (not (file-exists? mtcachef))) (configf:write-alist *configdat* mtcachef))
(if (and rccachef mtcachef *runconfigdat* *configdat*)
|
︙ | | |
Modified megatest.scm
from [7d727a3269]
to [bec19a07b1].
︙ | | |
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
|
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
|
+
+
+
-
+
+
|
(set! *didsomething* #t)))
;; handle a clean-cache request as early as possible
;;
(if (args:get-arg "-clean-cache")
(let ((toppath (launch:setup)))
(set! *didsomething* #t) ;; suppress the help output.
(runs:clean-cache (or (getenv "MT_TARGET")
(args:get-arg "-target")
(args:get-arg "-remtarg"))
(runs:clean-cache (getenv "MT_TARGET")(args:get-arg "-runname") toppath)))
(args:get-arg "-runname")
toppath)))
(if (args:get-arg "-env2file")
(begin
(save-environment-as-files (args:get-arg "-env2file"))
(set! *didsomething* #t)))
(if (args:get-arg "-list-disks")
|
︙ | | |
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
|
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
|
+
-
+
|
(directory-exists? rundir)
(file-write-access? rundir))
(begin
(if (not (common:in-running-test?))
(configf:write-alist data cfgf))
;; force re-read of megatest.config - this resolves circular references between megatest.config
(launch:setup force-reread: #t)
;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
)) ;; we can safely cache megatest.config since we have a valid runconfig
data))))
(if (args:get-arg "-show-runconfig")
(let ((tl (launch:setup)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
;; keep this one local
|
︙ | | |
Modified runs.scm
from [50559e5a2a]
to [e40956d9b1].
︙ | | |
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
|
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
|
+
-
+
|
(exit 3))
(else
(let (;; (db #f)
(keys #f))
(if (launch:setup)
(begin
(full-runconfigs-read) ;; cache the run config
;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
(launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed
) ;; do not cache here - need to be sure runconfigs is processed
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
|
︙ | | |
Modified tcmt.scm
from [524aac4380]
to [9a347b1c11].
︙ | | |
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
-
+
+
|
(let ((run-ids #f)
(testdat (make-hash-table))
(keys #f)
(last-update 0)
(target (or (args:get-arg "-target")
(args:get-arg "-reqtarg")))
(runname (args:get-arg "-runname"))
(tsname (common:get-testsuite-name)))
(tsname #f))
(if (and target runname)
(begin
(launch:setup)
(set! keys (rmt:get-keys))))
(set! tsname (common:get-testsuite-name))
(print "TCMT: for testsuite=" tsname " found runname=" runname " and target=" target " and successfully ran launch:setup")
(let loop ()
(handle-exceptions
exn
;; (print "Process done.")
(begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn)))
(let-values (((pidres exittype exitstatus)
|
︙ | | |