| ︙ | | | ︙ | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
(declare (uses mtconfigf))
(declare (uses itemsmod))
(declare (uses dbmod))
(module testsmod
*
(import scheme chicken data-structures extras files)
(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
format ports srfi-1 matchable
directory-utils
regex srfi-13)
(import commonmod)
(import servermod)
(import itemsmod)
|
|
|
|
|
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
|
(declare (uses mtconfigf))
(declare (uses itemsmod))
(declare (uses dbmod))
(module testsmod
*
(import scheme chicken.base chicken.file chicken.string chicken.process chicken.condition chicken.process-context)
(import chicken.sort chicken.file.posix chicken.io chicken.pathname chicken.process-context.posix)
(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69
chicken.format chicken.port srfi-1 matchable
directory-utils
regex srfi-13)
(import commonmod)
(import servermod)
(import itemsmod)
|
| ︙ | | | ︙ | |
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
;; The setting of :keyfield in args should be turned off ASAP
;;
(define (keys:target-set-args keys target ht)
(if target
(let ((vals (string-split target "/")))
(if (eq? (length vals)(length keys))
(for-each (lambda (key val)
(setenv key val)
(if ht (hash-table-set! ht (conc ":" key) val)))
keys
vals)
(debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
vals)
(debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
|
|
|
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
;; The setting of :keyfield in args should be turned off ASAP
;;
(define (keys:target-set-args keys target ht)
(if target
(let ((vals (string-split target "/")))
(if (eq? (length vals)(length keys))
(for-each (lambda (key val)
(set-environment-variable! key val)
(if ht (hash-table-set! ht (conc ":" key) val)))
keys
vals)
(debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
vals)
(debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
|
| ︙ | | | ︙ | |
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
|
local-tcdir
#f))
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (let loopa ((tries-left 30))
(cond
(
(and (common:file-exists? test-configf)(file-read-access? test-configf))
#t)
(
(common:file-exists? test-configf)
(debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf)
#f)
(
(and wait-a-minute (> tries-left 0))
|
|
|
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
|
local-tcdir
#f))
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (let loopa ((tries-left 30))
(cond
(
(and (common:file-exists? test-configf)(file-readable? test-configf))
#t)
(
(common:file-exists? test-configf)
(debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf)
#f)
(
(and wait-a-minute (> tries-left 0))
|
| ︙ | | | ︙ | |
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
"pre-launch-env-vars"
#f))
#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-write-access? cache-path)
allow-write-cache)
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
(if (and tcfg (not (common:in-running-test?)))
(configf:write-alist tcfg tpath))))
tcfg))))))
|
|
|
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
"pre-launch-env-vars"
#f))
#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)
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
(if (and tcfg (not (common:in-running-test?)))
(configf:write-alist tcfg tpath))))
tcfg))))))
|
| ︙ | | | ︙ | |
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
|
(conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
(lambda ()
(let ((res (read-lines)))
;; (delete-file temp-path)
res))))))
(define (tests:write-dot-file test-records fname sizex sizey)
(if (file-write-access? (pathname-directory fname))
(with-output-to-file fname
(lambda ()
(map print (tests:tests->dot test-records sizex sizey))))))
(define (tests:tests->dot test-records sizex sizey)
(let ((all-testnames (hash-table-keys test-records)))
(if (null? all-testnames)
|
|
|
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
|
(conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
(lambda ()
(let ((res (read-lines)))
;; (delete-file temp-path)
res))))))
(define (tests:write-dot-file test-records fname sizex sizey)
(if (file-writable? (pathname-directory fname))
(with-output-to-file fname
(lambda ()
(map print (tests:tests->dot test-records sizex sizey))))))
(define (tests:tests->dot test-records sizex sizey)
(let ((all-testnames (hash-table-keys test-records)))
(if (null? all-testnames)
|
| ︙ | | | ︙ | |