Megatest

Check-in [a8d4af197f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: a8d4af197f35baa2b255507ad1be0f03f5f814c0
User & Date: matt on 2021-04-18 20:58:19
Other Links: branch diff | manifest | tags
Context
2021-04-18
21:07
wiphtop check-in: cecf838aa0 user: matt tags: v1.6584-ck5
20:58
wip check-in: a8d4af197f user: matt tags: v1.6584-ck5
16:48
wip - renamed read-config to configf:read-config check-in: b252166d42 user: matt tags: v1.6584-ck5
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified bigmod.scm from [3ff83f9c3d] to [9d3b4cd8d6].

︙
17
18
19
20
21
22
23

24
25
26
27


28
29
30
31
32
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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74



































75
76
77
78



79
80




17
18
19
20
21
22
23
24
25
26


27
28
29
30
31
32
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
58
59
60
61
62
63
64
65
66
67
68
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
109
110
111
112


113
114
115
116

117
118
119








+


-
-
+
+




















+


-
-
+
+


-
+



















-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


-
-
+
+
+

-
+
+
+

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit bigmod))

(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses dbmod))
(declare (uses dbmod))
(declare (uses rmtmod))

(module bigmod
	()
(import scheme

	chicken.base
	chicken.condition
	chicken.file
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.sort
	chicken.string
	chicken.time
	chicken.module
	
	debugprint
	(prefix mtargs args:)
	commonmod
	configfmod
	dbmod
	rmtmod
;; 	dbmod
;;	rmtmod
	
	(prefix base64 base64:)
	(prefix dbi dbi:)
	;; (prefix dbi dbi:)
	(prefix sqlite3 sqlite3:)
	(srfi 18)
	directory-utils
	format
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors
	srfi-1
	srfi-13
	srfi-69
	stack
	typed-records
	z3
	
	)

(reexport debugprint
(reexport scheme

	  chicken.base
	  chicken.condition
	  chicken.file
	  chicken.io
	  chicken.pathname
	  chicken.port
	  chicken.pretty-print
	  chicken.process
	  chicken.process-context
	  chicken.sort
	  chicken.string
	  chicken.time
	  chicken.module
	  
	  (prefix base64 base64:)
	  ;; (prefix dbi dbi:)
	  (prefix sqlite3 sqlite3:)
	  (srfi 18)
	  directory-utils
	  format
	  matchable
	  md5
	  message-digest
	  regex
	  regex-case
	  sparse-vectors
	  srfi-1
	  srfi-13
	  srfi-69
	  stack
	  typed-records
	  z3

	  commonmod
	  configfmod
	  dbmod
	  rmtmod)
	  ;; dbmod
	  debugprint
	  ;; rmtmod

)
	  )

)

Modified commonmod.scm from [4cf1c3bb0a] to [0b83b5ae2b].

︙
1115
1116
1117
1118
1119
1120
1121
1122

1123
1124

1125
1126
1127
1128
1129
1130
1131

1115
1116
1117
1118
1119
1120
1121

1122
1123

1124
1125
1126
1127
1128
1129
1130
1131








-
+

-
+








		 (set! res #t))))
	 (string-split patts ","))
	res)
      #t))

;;======================================================================
;; '(print (string-intersperse (map cadr (hash-table-ref/default (configf:read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks #!key (configf #f))
(define (common:get-disks configf)
  (hash-table-ref/default 
   (or configf (configf:read-config "megatest.config" #f #t))
   configf ;; (or configf (configf:read-config "megatest.config" #f #t))
   "disks" '("none" "")))

;;======================================================================
;; return first command that exists, else #f
;;
(define (common:which cmds)
  (if (null? cmds)
︙
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234



1235
1236
1237


1238
1239
1240
1241
1242
1243
1244

1225
1226
1227
1228
1229
1230
1231



1232
1233
1234
1235
1236

1237
1238
1239
1240
1241
1242
1243
1244
1245








-
-
-
+
+
+


-
+
+








;; T A R G E T S  ,   S T A T E ,   S T A T U S ,   
;;                    R U N N A M E    A N D   T E S T P A T T
;;======================================================================

;;======================================================================
;; (map print (map car (hash-table->alist (configf:read-config "runconfigs.config" #f #t))))
;;
(define (common:get-runconfig-targets #!key (configf #f))
  (let ((targs       (sort (map car (hash-table->alist
				     (or configf ;; NOTE: There is no value in using runconfig:read here.
(define (common:get-runconfig-targets configf) ;; #!key (configf #f))
  (let ((targs       (sort (map car (hash-table->alist configf
						       #;(or configf ;; NOTE: There is no value in using runconfig:read here.
					 (configf:read-config (conc *toppath* "/runconfigs.config")
						      #f #t)
					 (make-hash-table))))
						       (make-hash-table))
						       ))
			   string<?))
	(target-patt (args:get-arg "-target")))
    (if target-patt
	(filter (lambda (x)
		  (patt-list-match x target-patt))
		targs)
	targs)))
︙
3155
3156
3157
3158
3159
3160
3161
3162

3163
3164
3165
3166
3167
3168
3169

3156
3157
3158
3159
3160
3161
3162

3163
3164
3165
3166
3167
3168
3169
3170








-
+








;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
;;
(define (common:load-views-config)
  (let* ((view-cfgdat    (make-hash-table))
	 (home-cfgfile   (conc (get-environment-variable "HOME") "/.mtviews.config"))
	 (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
    (if (common:file-exists? mthome-cfgfile)
	(configf:read-config mthome-cfgfile view-cfgdat #t))
	(configf:read-config mthome-cfgfile view-cfgdat))
    ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
    (if (common:file-exists? home-cfgfile)
	(configf:read-config home-cfgfile view-cfgdat #t))
    view-cfgdat))

;;======================================================================
;; H I E R A R C H I C A L   H A S H   T A B L E S
︙

Modified configfmod.scm from [f126e8c24b] to [6693a9270b].

︙
399
400
401
402
403
404
405
406

407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425

426
427
428
429
430
431
432

399
400
401
402
403
404
405

406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424

425
426
427
428
429
430
431
432








-
+


















-
+








					     (debug:print 2 *default-log-port* "        " full-conf))
					   (for-each
					    (lambda (fpath)
					      ;; (push-directory conf-dir)
					      (debug:print 9 *default-log-port* "Including: " full-conf)
					      (configf:read-config fpath res allow-system environ-patt: environ-patt
							   curr-section: curr-section-name sections: sections settings: settings
							   keep-filenames: keep-filenames))
							   keep-filenames: keep-filenames env-to-use: env-to-use))
					    all-matches))
				       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings env-to-use)
					     curr-section-name #f #f))))
	       (configf:script-rx ( x include-script params);; handle-exceptions
                                  ;;    exn
                                  ;;    (begin
                                  ;;      (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
                                  ;;      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
                                  (if (and (file-exists? include-script)(file-executable? include-script))
                                      (let* ((local-allow-system  (calc-allow-system allow-system curr-section-name sections))
                                             (env-delta  (configf:cfgdat->env-alist curr-section-name res local-allow-system))
                                             (new-inp-port
                                              (common:with-env-vars
                                               env-delta
                                               (lambda ()
                                                 (open-input-pipe (conc include-script " " params))))))
                                        (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
                                        ;;  (print "We got here, calling configf:read-config next. Port is: " new-inp-port)
                                        (configf:read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
                                        (configf:read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames env-to-use: env-to-use)
                                        (close-input-port new-inp-port)
                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings env-to-use) curr-section-name #f #f))
                                      (begin
                                        (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
                                        (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings env-to-use) curr-section-name #f #f)))
                                  ) ;; )
	       (configf:section-rx ( x section-name )
︙
608
609
610
611
612
613
614

615

616
617
618
619
620
621
622

608
609
610
611
612
613
614
615

616
617
618
619
620
621
622
623








+
-
+








;;     ;;	    (list var val))))
;; 
;;======================================================================
;; setup
;;======================================================================
;;======================================================================

;; This should not be here.
(define (setup)
#;(define (setup)
  (let* ((configf (find-config "megatest.config"))
	 (config  (if configf (configf:read-config configf #f #t) #f)))
    (if config
	(setenv "RUN_AREA_HOME" (pathname-directory configf)))
    config))

(define (safe-setenv key val)
︙
950
951
952
953
954
955
956
957

958
959
960
961
962
963
964

951
952
953
954
955
956
957

958
959
960
961
962
963
964
965








-
+








    (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))

;;======================================================================
;; Config file handling
;;======================================================================

;; convert to param?
(define configf:std-imports "(import configfmod commonmod)")
(define configf:std-imports "") ;;(import configfmod commonmod)")

(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(let ((matchdat (string-search configf:var-expand-regex res)))
	  (if matchdat
	      (let* ((prestr  (list-ref matchdat 1))
︙
986
987
988
989
990
991
992
993

994
995
996
997
998
999
1000

987
988
989
990
991
992
993

994
995
996
997
998
999
1000
1001








-
+








				       ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
				       (else
					(debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
					"(lambda (ht) #f)")))
			       ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
			       ;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
			       (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))))
		(print "fullcmd=" fullcmd)
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
		   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
		   ;; (print "exn=" (condition->list exn))
		   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
︙
1015
1016
1017
1018
1019
1020
1021
1022

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035

1036
1037
1038
1039
1040
1041
1042

1016
1017
1018
1019
1020
1021
1022

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035

1036
1037
1038
1039
1040
1041
1042
1043








-
+












-
+








			 (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " delta " seconds to run with output:\n   " result)))))
		(loop (conc prestr result poststr)))
	      res))
	res)))

  
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
(define (configf:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(env-to-use #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))
	 (set-fields (lambda (curr-section next-section ht path)
		       (let ((field-names (if ht (common:get-fields ht) '()))
			     (target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
			 (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
			 (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (configf:read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
			  (configf:read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f env-to-use: env-to-use))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

;;======================================================================
;; Non destructive writing of config file
;;======================================================================
︙

Modified dbmod.scm from [7b37a0ea03] to [6d0e6f1813].

︙
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

56
57
58
59
60
61
62

34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

56
57
58
59
60
61
62
63








+














-
+








(module dbmod
	*
	
(import scheme
	(prefix sqlite3 sqlite3:)
	chicken.base
	chicken.condition
	chicken.eval
	chicken.file
	chicken.file.posix
	chicken.format
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.sort
	chicken.string
	chicken.time
	chicken.time.posix

	
	(prefix base64 base64:)
	csv-xml
	directory-utils
	matchable
	regex
	s11n
	srfi-1
︙
5381
5382
5383
5384
5385
5386
5387
5388


5389
5390

5391
5392
5393
5394
5395
5396
5397

5382
5383
5384
5385
5386
5387
5388

5389
5390
5391

5392
5393
5394
5395
5396
5397
5398
5399








-
+
+

-
+








	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))
	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? tconfig-file)
		       (file-readable? tconfig-file))
		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
			(old-link-tree  (get-environment-variable "MT_LINKTREE")))
			(old-link-tree  (get-environment-variable "MT_LINKTREE"))
			(bigmodenv      (module-environment 'bigmod)))
		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
		    (let ((newtcfg (configf:read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
		    (let ((newtcfg (configf:read-config tconfig-file #f #f env-to-use: bigmodenv))) ;; NOTE: Does NOT run [system ...]
		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)
			  (unsetenv "MT_LINKTREE"))
		      newtcfg))
		  (if (null? tal)
		      (begin
︙

Modified ezstepsmod.scm from [0ccdb56647] to [857570fa0d].

︙
35
36
37
38
39
40
41

42
43
44
45
46
47
48

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49








+








(module ezstepsmod
	*
	
(import scheme
	(prefix sqlite3 sqlite3:)
	chicken.base
	chicken.condition
	chicken.eval
	chicken.file
	chicken.file.posix
	chicken.format
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
︙
298
299
300
301
302
303
304

305

306
307
308
309
310
311
312

299
300
301
302
303
304
305
306

307
308
309
310
311
312
313
314








+
-
+








    logpro-used))

(define (ezsteps:run-from testdat start-step-name run-one)
  ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
  (let* ((do-update-test-state-status #f)
         (test-run-dir  ;; (filedb:get-path *fdb* 
	  (db:test-get-rundir testdat)) ;; )
	 (bigmodenv     (module-environment 'bigmod))
	 (testconfig    (configf:read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (testconfig    (configf:read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars" env-to-use: bigmodenv))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
         (rollup-status-string #f)
         (rollup-status-sym #f)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id        testdat))
︙

Modified launchmod.scm from [26d0caba3d] to [f226b54f79].

︙
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45

46
47
48
49
50
51
52

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54








+








+








(declare (uses mtmod))
(declare (uses mtver))
(declare (uses processmod))
(declare (uses rmtmod))
(declare (uses servermod))
(declare (uses subrunmod))
(declare (uses testsmod))
(declare (uses bigmod))

(module launchmod
	*
	
(import scheme
	(prefix sqlite3 sqlite3:)
	chicken.base
	chicken.condition
	chicken.eval
	chicken.file
	chicken.file.posix
	chicken.format
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
︙
77
78
79
80
81
82
83

84
85
86
87
88
89
90

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93








+








	z3
	sxml-serializer
	sxml-modifications
	(prefix sxml-modifications sxml-)
	sxml-transforms
	
	(prefix mtargs args:)
	bigmod
	commonmod
	configfmod
	dbmod
	debugprint
	ezstepsmod
	keysmod
	mtmod
︙
885
886
887
888
889
890
891

892

893
894
895
896


897
898
899
900
901
902
903
904
905
906


907
908
909
910
911
912
913

888
889
890
891
892
893
894
895

896
897
898
899

900
901
902
903
904
905
906
907
908
909
910

911
912
913
914
915
916
917
918
919








+
-
+



-
+
+









-
+
+








	  *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
	       rccachef) ;; BB- why are we doing this without asking if caching is desired?
          ;;(BB> "launch:setup-body -- cond branch 2")
	  (let* ((bigmodenv     (module-environment 'bigmod))
	  (let* ((first-pass    (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
		 (first-pass    (configf: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"))
				 pathenvvar: "MT_RUN_AREA_HOME"
				 env-to-use: bigmodenv))
		 (first-rundat  (let ((toppath (if toppath 
						   toppath
						   (car first-pass))))
				  (configf:read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
				   (conc (if (string? toppath)
					     toppath
					     (get-environment-variable "MT_RUN_AREA_HOME"))
					 "/runconfigs.config")
				   *runconfigdat* #t 
				   sections: sections))))
				   sections: sections
				   env-to-use: bigmodenv))))
	    (set! *runconfigdat* first-rundat)
	    (if first-pass  ;; 
		(begin
                  ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass")
		  (set! *configdat*  (car first-pass))
                  ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*)
		  (set! *configinfo* first-pass)
︙
922
923
924
925
926
927
928
929

930
931
932
933


934
935
936
937
938
939
940

928
929
930
931
932
933
934

935
936
937
938

939
940
941
942
943
944
945
946
947








-
+



-
+
+








		  (let* ((keys         (common:list-or-null (rmt:get-keys)
							    message: "Failed to retrieve keys in launch.scm. Please report this to the developers."))
			 (key-vals     (keys:target->keyval keys target))
			 (linktree     (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
					;     (if *configdat*
					; 	   (configf:lookup *configdat* "setup" "linktree")
					; 	   (conc *toppath* "/lt"))))
			 (second-pass  (find-and-read-config
			 (second-pass  (configf:find-and-read-config
					mtconfig
					environ-patt: "env-override"
					given-toppath: toppath
					pathenvvar: "MT_RUN_AREA_HOME"))
					pathenvvar: "MT_RUN_AREA_HOME"
					env-to-use: (module-environment 'bigmod)))
			 (runconfigdat (begin     ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
					 (for-each (lambda (kt)
						     (setenv (car kt) (cadr kt)))
						   key-vals)
					 (configf: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))
︙
960
961
962
963
964
965
966
967

968
969
970
971


972
973
974
975
976
977
978

967
968
969
970
971
972
973

974
975
976
977

978
979
980
981
982
983
984
985
986








-
+



-
+
+








		(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 
	  (let* ((cfgdat   (configf: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")))
			    pathenvvar: "MT_RUN_AREA_HOME"
			    env-to-read: (module-environment 'bigmod))))

            (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     (configf:read-config (conc toppath  ;; convert this to use runconfig:read!
						    "/runconfigs.config") *runconfigdat* #t sections: sections)))
		  (set! *configinfo*   cfgdat)
		  (set! *configdat*    (car cfgdat))
︙
2243
2244
2245
2246
2247
2248
2249

2250

2251
2252
2253
2254
2255
2256
2257

2251
2252
2253
2254
2255
2256
2257
2258

2259
2260
2261
2262
2263
2264
2265
2266








+
-
+








		     #f))
	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
    (if (and cfgf
	     (common:file-exists? cfgf)
	     (file-writable? cfgf)
	     (common:use-cache?))
	(configf:read-alist cfgf)
	(let* ((gotit  (if cfgf #t (launch:setup)))  ;; whatever
	(let* ((keys   (common:get-fields cfgf)) ;; (rmt:get-keys))
	       (keys   (common:get-fields cfgf))     ;; (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)
︙

Modified megatest.scm from [aec1731c6e] to [f5acd0dd12].

︙
23
24
25
26
27
28
29

30
31
32
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
58
59
60
61
62
63
64
65
66
67
68
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
109
110
111
112
113

23
24
25
26
27
28
29
30
31
32
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
58
59
60
61
62
63
64
65
66
67
68
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
109
110

111
112
113

114
115
116


117
118





119
120
121
122
123
124
125
126








+




+












+
+
+
+
+
+
+
+
+
+










+




















+

-
+




+
+

+






-
-
-


+
+
+
-
+
+

-
+


-
-
+

-
-
-
-
-
+








(declare (uses csv-xml))
(declare (uses hostinfo))

(declare (uses adjutant))
(declare (uses archivemod))
(declare (uses apimod))
(declare (uses autoload))
(declare (uses bigmod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses dbi))
(declare (uses debugprint))
(declare (uses ducttape-lib))
(declare (uses ezstepsmod))
(declare (uses http-transportmod))
(declare (uses launchmod))
(declare (uses mtargs))
(declare (uses mtver))
(declare (uses mutils))
(declare (uses processmod))
(declare (uses rmtmod))
(declare (uses runsmod))
(declare (uses servermod))
(declare (uses testsmod))

;; needed for configf scripts, scheme etc.
(declare (uses apimod.import))
(declare (uses debugprint.import))
(declare (uses mtargs.import))
(declare (uses commonmod.import))
(declare (uses configfmod.import))
(declare (uses bigmod.import))
(declare (uses dbmod.import))
(declare (uses rmtmod.import))

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module megatest-main
	*

  (import scheme
	  chicken.base
	  chicken.bitwise
	  chicken.condition
	  chicken.eval
	  chicken.file
	  chicken.file.posix
	  chicken.format
	  chicken.io
	  chicken.irregex
	  chicken.pathname
	  chicken.port
	  chicken.pretty-print
	  chicken.process
	  chicken.process-context
	  chicken.process-context.posix
	  chicken.process.signal
	  chicken.random
	  chicken.repl
	  chicken.sort
	  chicken.string
	  chicken.tcp
	  chicken.time
	  chicken.time.posix
	  
	  (prefix base64 base64:)
	  (prefix sqlite3 sqlite3:)
	  (prefix base64 base64:)
	  (prefix sxml-modifications sxml-)
	  address-info
	  csv-abnf
	  directory-utils
	  fmt
	  http-client
	  intarweb
	  json
	  linenoise
	  matchable
	  md5
	  message-digest
	  queues
	  regex
	  regex-case
	  sql-de-lite
	  stack
	  typed-records
	  s11n
	  sparse-vectors
	  spiffy
	  spiffy-directory-listing
	  spiffy-request-vars
	  sxml-serializer
	  sql-de-lite
	  stack
	  sxml-modifications
	  (prefix sxml-modifications sxml-)
	  sxml-serializer
	  sxml-transforms
	  system-information
	  z3
	  spiffy
	  typed-records
	  uri-common
	  intarweb
	  http-client
	  spiffy-request-vars
	  intarweb
	  spiffy-directory-listing
	  z3
	  
	  srfi-1
	  srfi-4
	  srfi-18
	  srfi-13
	  srfi-98
	  srfi-69
︙
124
125
126
127
128
129
130
131

132

133
134
135
136
137
138
139
140
141
142
143
144

145
146
147
148
149
150
151

137
138
139
140
141
142
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157

158
159
160
161
162
163
164
165








-
+

+











-
+








	  csv-xml
	  ducttape-lib
	  (prefix mtargs args:)
	  pkts
	  stml2
	  (prefix dbi dbi:)

	  ;; apimod
	  apimod
	  archivemod
	  bigmod
	  commonmod
	  configfmod
	  dbmod
	  debugprint
	  ezstepsmod
	  http-transportmod
	  launchmod
	  processmod
	  rmtmod
	  runsmod
	  servermod
	  ;; tasksmod
	  tasksmod
	  testsmod
	  
	  )
	
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
︙
2442
2443
2444
2445
2446
2447
2448
2449





















2450
2451
2452
2453
2454
2455
2456

2456
2457
2458
2459
2460
2461
2462

2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490








-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








     	    (repl))
     	   (else
     	    (begin
     	      (set! *db* dbstruct)
     	      ;; (import extras) ;; might not be needed
     	      ;; (import csi)
     	      ;; (import readline)
     	      (import apropos)
     	      (import apropos
		      archivemod
		      commonmod
		      configfmod
		      dbmod
		      debugprint
		      ezstepsmod
		      http-transportmod
		      launchmod
		      processmod
		      rmtmod
		      runsmod
		      servermod
		      tasksmod
		      testsmod)

	      (set-history-length! 300)
	      
	      (load-history-from-file ".megatest_history")
	      
	      (current-input-port (make-linenoise-port))
     	      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
     
     	;; (if *use-new-readline*
     	;; 	  (begin
     	;; 	    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
     	;; 	    (current-input-port (make-readline-port "megatest> ")))
     	;; 	  (begin
︙

Modified runsmod.scm from [8b969957a6] to [1219e25fbf].

︙
42
43
44
45
46
47
48

49
50
51
52
53
54
55

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56








+








(module runsmod
	*
	
(import scheme
	(prefix sqlite3 sqlite3:)
	chicken.base
	chicken.condition
	chicken.eval
	chicken.file
	chicken.file.posix
	chicken.format
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
︙
2529
2530
2531
2532
2533
2534
2535
2536

2537
2538
2539
2540
2541
2542
2543

2530
2531
2532
2533
2534
2535
2536

2537
2538
2539
2540
2541
2542
2543
2544








-
+








	      (exit 1)))

        
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (configf:read-config runconfigf #f #t environ-patt: #f)))
		   (runconfig  (configf:read-config runconfigf #f #t environ-patt: #f env-to-use: (module-environment 'bigmod))))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		    
		  (begin
		    (debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    ;; (if db (sqlite3:finalize! db))
		    (exit 1)
︙

Modified testsmod.scm from [61c8f37d49] to [b61c571478].

︙
36
37
38
39
40
41
42

43
44
45
46
47
48
49

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50








+








(import scheme

	chicken.base
	chicken.condition
	chicken.file
	chicken.io
	chicken.pathname
	chicken.eval
	chicken.file.posix
	chicken.process-context.posix
	chicken.format
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
︙
1076
1077
1078
1079
1080
1081
1082
1083


1084
1085
1086
1087
1088
1089
1090

1077
1078
1079
1080
1081
1082
1083

1084
1085
1086
1087
1088
1089
1090
1091
1092








-
+
+








                                      (else
                                       (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires
                                       #f))))
		     (tcfg         (if testexists
				       (configf:read-config test-configf #f system-allowed
						    environ-patt: (if system-allowed
								      "pre-launch-env-vars"
								      #f))
								      #f)
						    env-to-use: (module-environment 'bigmod))
				       #f)))
		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-writable? cache-path)
			 allow-write-cache)
︙

This page was generated in about 0.122s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00