Megatest

Check-in [d6d1370c83]
Login
Overview
Comment:updated env-delta calculator to honor allow-system; bumped version to 1.6435
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.64-runvar
Files: files | file ages | folders
SHA1: d6d1370c8374e813aca7a3ed0e56f50a90170052
User & Date: bjbarcla on 2017-10-23 14:51:39
Other Links: branch diff | manifest | tags
Context
2017-10-23
14:52
resolved target variables not being seen by item elaboration system calls issue check-in: a67b8a13ee user: bjbarcla tags: v1.64, v1.6435
14:51
updated env-delta calculator to honor allow-system; bumped version to 1.6435 Leaf check-in: d6d1370c83 user: bjbarcla tags: v1.64-runvar
2017-10-20
18:17
removed envdelta stuff that was a dead end check-in: 48b44ebc9c user: bjbarcla tags: v1.64-runvar
Changes

Modified configf.scm from [897b6d0f2a] to [a91d357ccf].

178
179
180
181
182
183
184
185

186
187
188
189
190
191
192

193

194
195
196
197
198
199
200
178
179
180
181
182
183
184

185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201







-
+






-
+

+







		       (else
			(configf:process-line inl ht allow-processing)))))
	    (if (and (string? res)
		     (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
		(string-substitute "\\s+$" "" res)
		res))))))

(define (configf:cfgdat->env-alist section cfgdat-ht)
(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
  (filter
   (lambda (pair)
     (let* ((var (car pair))
            (val (cdr pair)))
       (cons var
             (cond
              ((procedure? val)
              ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
               (val))
              ((procedure? val) #f)
              ((string? val) val)
              (else "#f")))))
   (append
    (hash-table-ref/default cfgdat-ht "default" '())
    (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))

(define (calc-allow-system allow-system section sections)
233
234
235
236
237
238
239





240
241
242
243
244
245
246
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252







+
+
+
+
+







         (hash-table-keys ht))))
  ht)

;; read a config file, returns hash table of alists

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
;;    #f - do not evaluate [system
;;    #t - immediately evaluate [system and store result as string
;;    'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
;;    'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
325
326
327
328
329
330
331

332

333
334
335
336
337
338
339
331
332
333
334
335
336
337
338

339
340
341
342
343
344
345
346







+
-
+







                                                                    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 (common:file-exists? include-script)(file-execute-access? include-script))
                                      (let* ((local-allow-system  (calc-allow-system allow-system curr-section-name sections))
                                      (let* ((env-delta  (configf:cfgdat->env-alist curr-section-name res))
                                             (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 read-config next. Port is: " new-inp-port)
366
367
368
369
370
371
372

373

374
375
376
377
378
379
380
373
374
375
376
377
378
379
380

381
382
383
384
385
386
387
388







+
-
+







                                           section-name
                                           #f #f)))
	       (configf:key-sys-pr ( x key cmd      )
                                   (if (calc-allow-system allow-system curr-section-name sections)
                                       (let ((alist    (hash-table-ref/default res curr-section-name '()))
                                             (val-proc (lambda ()
                                                         (let* ((start-time (current-seconds))
                                                                (local-allow-system  (calc-allow-system allow-system curr-section-name sections))
                                                                (env-delta  (configf:cfgdat->env-alist curr-section-name res))
                                                                (env-delta  (configf:cfgdat->env-alist curr-section-name res local-allow-system))
                                                                (cmdres     (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd.  needs to have env from other vars!
                                                                (delta      (- (current-seconds) start-time))
                                                                (status     (cadr cmdres))
                                                                (res        (car  cmdres)))
                                                           (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
                                                           (if (not (eq? status 0))
                                                               (begin

Modified megatest-version.scm from [288fcfb74a] to [8a4188e408].

1
2
3
4
5
6

7
1
2
3
4
5

6
7





-
+

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6434)
(define megatest-version 1.6435)

Modified tests.scm from [171321d60f] to [03a30c9a87].

144
145
146
147
148
149
150
151

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

151
152
153
154
155
156
157
158







-
+







      (items:get-items-from-config tconfig))
     (else #f))))                           ;; not iterated


;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
   (let* ((config  (tests:get-testconfig test-name #f all-tests-registry 'return-procs)))
   (let* ((config  (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
     (let ((instr (if config 
		      (config-lookup config "requirements" "waiton")
		      (begin ;; No config means this is a non-existant test
			(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
			(exit 1))))
	   (instr2 (if config
		       (config-lookup config "requirements" "waitor")