733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
|
(getenv "MT_TARGET") "/"
(getenv "MT_RUNNAME") "/"
(getenv "MT_TEST_NAME") "/"
(if (or (getenv "MT_ITEMPATH")
(not (string=? "" (getenv "MT_ITEMPATH"))))
(conc "/" (getenv "MT_ITEMPATH"))))))
(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f))
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (hash-table-ref/default
treg test-name
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(cache-path (tests:get-test-path-from-environment))
(cache-exists (and cache-path
(not force-create) ;; if force-create then pretend there is no cache to read
(file-exists? (conc cache-path "/.testconfig"))))
(cache-file (conc cache-path "/.testconfig"))
(tcfg (if testexists
(or (and (not force-create)
cache-exists
(handle-exceptions
exn
(begin
(debug:print 0 "WARNING: Failed to read " cache-file)
(make-hash-table)) ;; better to return a hash and keep going - I think
(configf:read-alist cache-file)))
(read-config test-configf #f system-allowed environ-patt: (if system-allowed
"pre-launch-env-vars"
#f)))
#f)))
(hash-table-set! *testconfigs* test-name tcfg)
(if (and testexists
cache-path
(not cache-exists)
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 "Caching testconfig for " test-name " in " tpath)
(configf:write-alist tcfg tpath)))
tcfg))
;; 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-records)
(let* ((mungepriority (lambda (priority)
(if priority
(let ((tmp (any->number priority)))
|
>
>
>
>
>
<
<
<
<
<
<
<
|
>
|
|
<
<
|
|
|
|
<
<
<
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|
>
|
|
|
<
|
|
|
|
|
|
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
|
(getenv "MT_TARGET") "/"
(getenv "MT_RUNNAME") "/"
(getenv "MT_TEST_NAME") "/"
(if (or (getenv "MT_ITEMPATH")
(not (string=? "" (getenv "MT_ITEMPATH"))))
(conc "/" (getenv "MT_ITEMPATH"))))))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f))
(let* ((cache-path (tests:get-test-path-from-environment))
(cache-file (and cache-path (conc cache-path "/.testconfig")))
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(file-exists? cache-file)))
(cached-dat (if (and (not force-create)
cache-exists)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
#f)))
(if cached-dat
cached-dat
(let ((dat (hash-table-ref/default *testconfigs* test-name #f)))
(if (and dat ;; have a locally cached version
(hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
dat
;; no cached data available
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (or (hash-table-ref/default treg test-name #f)
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(tcfg (if testexists
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-name tcfg))
(if (and testexists
cache-file
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 "Caching testconfig for " test-name " in " tpath)
(configf:write-alist tcfg tpath)))
tcfg))))))
;; 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-records)
(let* ((mungepriority (lambda (priority)
(if priority
(let ((tmp (any->number priority)))
|
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
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
896
897
898
899
|
(define (tests:easy-dot test-records outtype)
(let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
(let ((all-testnames (hash-table-keys test-records))
(temp-port (open-output-file* fd)))
;; (format temp-port "This file is ~A.~%" temp-path)
(format temp-port "digraph tests {\n")
;; (format temp-port " splines=none\n")
(for-each
(lambda (testname)
(let* ((testrec (hash-table-ref test-records testname))
(waitons (or (tests:testqueue-get-waitons testrec) '())))
(for-each
(lambda (waiton)
(format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n")))
waitons)))
all-testnames)
(format temp-port "}\n")
(close-output-port temp-port)
(with-input-from-pipe
(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)
(if (file-write-access? (pathname-directory fname))
(with-output-to-file fname
(lambda ()
(map print (tests:tests->dot test-records))))))
(define (tests:tests->dot test-records)
(let ((all-testnames (hash-table-keys test-records)))
(if (null? all-testnames)
'()
(let loop ((hed (car all-testnames))
(tal (cdr all-testnames))
(res (list "digraph tests {")))
(let* ((testrec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(newres (append res
(if (null? waitons)
(list (conc " \"" hed "\";"))
(map (lambda (waiton)
(conc " \"" waiton "\" -> \"" hed "\";"))
waitons)
))))
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
))))))
|
>
|
|
|
|
>
>
>
|
|
|
858
859
860
861
862
863
864
865
866
867
868
869
870
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
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
|
(define (tests:easy-dot test-records outtype)
(let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
(let ((all-testnames (hash-table-keys test-records))
(temp-port (open-output-file* fd)))
;; (format temp-port "This file is ~A.~%" temp-path)
(format temp-port "digraph tests {\n")
(format temp-port " size=4,8\n")
;; (format temp-port " splines=none\n")
(for-each
(lambda (testname)
(let* ((testrec (hash-table-ref test-records testname))
(waitons (or (tests:testqueue-get-waitons testrec) '())))
(for-each
(lambda (waiton)
(format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n")))
waitons)))
all-testnames)
(format temp-port "}\n")
(close-output-port temp-port)
(with-input-from-pipe
(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)
'()
(let loop ((hed (car all-testnames))
(tal (cdr all-testnames))
(res (list "digraph tests {"
(conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
" ratio=0.95;"
)))
(let* ((testrec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(newres (append res
(if (null? waitons)
(list (conc " \"" hed "\" [shape=box];"))
(map (lambda (waiton)
(conc " \"" waiton "\" -> \"" hed "\" [shape=box];"))
waitons)
))))
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
))))))
|
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
|
(read-lines)))))
(close-input-port inp)
res)))
;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords outtype)
(let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
(tests:write-dot-file testrecords dfile)
(if (file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
|
|
|
|
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
|
(read-lines)))))
(close-input-port inp)
res)))
;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords outtype sizex sizey)
(let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
(tests:write-dot-file testrecords dfile sizex sizey)
(if (file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
|