Megatest

Check-in [ff05a10939]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Checking in partial fix for envvar handling
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.31
Files: files | file ages | folders
SHA1: ff05a109394695e2ad2c2bfa2500b0ea3e70b784
User & Date: mrwellan on 2011-11-02 15:32:18
Other Links: manifest | tags
Context
2011-11-02
21:59
Merged from envhandling branch check-in: da715ac6ab user: matt tags: trunk, v1.32
18:09
envvar handling is not reentrant. Need a better solution. Putting this stuff on a branch for now check-in: b71bf64192 user: mrwellan tags: envhandling
15:32
Checking in partial fix for envvar handling check-in: ff05a10939 user: mrwellan tags: trunk, v1.31
11:10
Bumped version check-in: 26ce838a3c user: mrwellan tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified configf.scm from [1be2fcacac] to [4a3f07b3f3].

︙︙
32
33
34
35
36
37
38





39
40
41



42
43
44
45
46
47
48
49

	      (if (null? remcwd)
		  (list #f #f #f) ;;  #f #f) 
		  (loop remcwd))))))))

(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (list key val)))))






;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)



(define (read-config path ht allow-system)
  (if (not (file-exists? path))
      (if (not ht)(make-hash-table) ht)
      (let ((inp        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))








>
>
>
>
>



>
>
>
|








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

	      (if (null? remcwd)
		  (list #f #f #f) ;;  #f #f) 
		  (loop remcwd))))))))

(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (list key val)))))

(define (config:eval-string-in-environment str)
  (let ((cmdres (cmd-run->list (conc "echo " str))))
    (if (null? cmdres) ""
	(car cmdres))))

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly

(define (read-config path ht allow-system #!key (environ-patt #f))
  (if (not (file-exists? path))
      (if (not ht)(make-hash-table) ht)
      (let ((inp        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))
︙︙
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

		(close-input-port inp)
		res)
	      (regex-case 
	       inl 
	       (comment-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res allow-system)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (if allow-system
						  (let ((alist (hash-table-ref/default res curr-section-name '()))
							(val   (let* ((cmdres  (cmd-run->list cmd))
								      (status  (cadr cmdres))
								      (res     (car  cmdres)))
								 (if (not (eq? status 0))
								     (begin
								       (debug:print 0 "ERROR: problem with " inl ", return code " status)
								       (exit 1)))
								 (if (null? res)
								     ""
								     (string-intersperse res " ")))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist key val))
						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let ((alist (hash-table-ref/default res curr-section-name '())))



						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
						(loop (read-line inp) curr-section-name key #f)))
	       ;; if a continued line
	       (cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 
								   (config-lookup res curr-section-name var-flag) "\n"
								   ;; trim lead from the incoming whsp to support some indenting.
								   (if lead
								       (string-substitute (regexp lead) "" whsp)
								       "")
								   val)))
						      ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
						      (hash-table-set! res curr-section-name 
								       (config:assoc-safe-add alist var-flag newval))
						      (loop (read-line inp) curr-section-name var-flag (if lead lead whsp)))
						    (loop (read-line inp) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (read-line inp) curr-section-name #f #f))))))))
  
(define (find-and-read-config fname)
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
    (if toppath (change-directory toppath)) 
    (let ((configdat  (if configfile (read-config configfile #f #t) #f))) ;; (make-hash-table))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

(define (config-lookup cfgdat section var)
  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	#f








|


















|
>
>
>

|




















|





|








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
127
128
129
130
131
132
133

		(close-input-port inp)
		res)
	      (regex-case 
	       inl 
	       (comment-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res allow-system environ-patt: environ-patt)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (if allow-system
						  (let ((alist (hash-table-ref/default res curr-section-name '()))
							(val   (let* ((cmdres  (cmd-run->list cmd))
								      (status  (cadr cmdres))
								      (res     (car  cmdres)))
								 (if (not (eq? status 0))
								     (begin
								       (debug:print 0 "ERROR: problem with " inl ", return code " status)
								       (exit 1)))
								 (if (null? res)
								     ""
								     (string-intersperse res " ")))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist key val))
						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let ((alist   (hash-table-ref/default res curr-section-name '()))
						    (realval (if (and environ-patt (string-match (regexp environ-patt) curr-section-name))
								 (config:eval-string-in-environment val)
								 val)))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key realval))
						(loop (read-line inp) curr-section-name key #f)))
	       ;; if a continued line
	       (cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 
								   (config-lookup res curr-section-name var-flag) "\n"
								   ;; trim lead from the incoming whsp to support some indenting.
								   (if lead
								       (string-substitute (regexp lead) "" whsp)
								       "")
								   val)))
						      ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
						      (hash-table-set! res curr-section-name 
								       (config:assoc-safe-add alist var-flag newval))
						      (loop (read-line inp) curr-section-name var-flag (if lead lead whsp)))
						    (loop (read-line inp) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (read-line inp) curr-section-name #f #f))))))))
  
(define (find-and-read-config fname #!key (environ-patt #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
    (if toppath (change-directory toppath)) 
    (let ((configdat  (if configfile (read-config configfile #f #t environ-patt: environ-patt) #f))) ;; (make-hash-table))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

(define (config-lookup cfgdat section var)
  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	#f
︙︙

Modified launch.scm from [d6ce07b497] to [ce1a0162c8].

︙︙
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

					      (begin
						(thread-sleep! 2)
						(loop (+ i 1)))
					      )))))
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t)) ;; FIXME??? is allow-system ok here?
					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
					    (db         (open-db)))
				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))








|








137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

					      (begin
						(thread-sleep! 2)
						(loop (+ i 1)))
					      )))))
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
					    (db         (open-db)))
				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
︙︙

Modified runs.scm from [13873526f6] to [b12c8bbbfa].

︙︙
502
503
504
505
506
507
508
509


510
511
512
513
514
515
516

	      #f)))))

(define (test:get-testconfig test-name system-allowed)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf))))
    (if testexists
	(read-config test-configf #f system-allowed)


	#f)))
  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-names)
  (let ((testdetails   (make-hash-table))
	(mungepriority (lambda (priority)








|
>
>








502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

	      #f)))))

(define (test:get-testconfig test-name system-allowed)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf))))
    (if testexists
	(read-config test-configf #f system-allowed environ-patt: (if system-allowed
								      "pre-launch-env-vars"
								      #f))
	#f)))
  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-names)
  (let ((testdetails   (make-hash-table))
	(mungepriority (lambda (priority)
︙︙
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206

	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db   (open-db))
	(set! keys (db-get-keys db))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config"))
		   (runconfig  (read-config runconfigf #f #f)))
	      (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 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    (sqlite3:finalize! db)
		    (exit 1))))
	    (if (args:get-arg "-target")








|
|








1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208

	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db   (open-db))
	(set! keys (db-get-keys db))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; evaluate all 
		   (runconfig  (read-config runconfigf #f #f environ-patt: ".*"))) 
	      (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 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    (sqlite3:finalize! db)
		    (exit 1))))
	    (if (args:get-arg "-target")
︙︙

Modified tests/runconfigs.config from [939e5a467b] to [bf935869e9]. 

1
2
3
4
5
6
7
8
9
10
11
12


[/tmp/mrwellan/env/ubuntu/afs]
BOGOUS Bob

[default/ubuntu/nfs]
CURRENT     /blah

[ubuntu/nfs/none]
CURRENT     /tmp/nada


[default]
FOOBARBAZZZZ not a useful value














>

1
2
3
4
5
6
7
8
9
10
11
12
13

[/tmp/mrwellan/env/ubuntu/afs]
BOGOUS Bob

[default/ubuntu/nfs]
CURRENT     /blah

[ubuntu/nfs/none]
CURRENT     /tmp/nada


[default]
FOOBARBAZZZZ not a useful value
BIGBOB $BOGOUS/bobby

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