726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
|
(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)
(let* ((test-path (hash-table-ref/default
test-registry 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 (file-exists? (conc cache-path "/.testconfig"))))
(cache-file (conc cache-path "/.testconfig"))
(tcfg (if testexists
(or (and cache-exists
(handle-exceptions
exn
(begin
(debug:print 0 "WARNING: Failed to read " cache-file)
|
|
|
>
>
|
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
|
(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* ((test-path (hash-table-ref/default
test-registry 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 cache-exists
(handle-exceptions
exn
(begin
(debug:print 0 "WARNING: Failed to read " cache-file)
|
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
|
(sort-fn2
(lambda (a b)
(> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
(mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
;; (debug:print "dot-res=" dot-res))
(let ((data (map cdr (filter
(lambda (x)(equal? "node" (car x)))
(map string-split (tests:easy-dot test-records "plain"))))))
(map car (sort data (lambda (a b)
(> (string->number (caddr a))(string->number (caddr b)))))))
))
;; (sort all-tests sort-fn1))) ;; avoid dealing with deleted tests, look at the hash table
(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")
|
|
|
|
|
|
|
|
|
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
|
(sort-fn2
(lambda (a b)
(> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
(mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
;; (debug:print "dot-res=" dot-res))
;; (let ((data (map cdr (filter
;; (lambda (x)(equal? "node" (car x)))
;; (map string-split (tests:easy-dot test-records "plain"))))))
;; (map car (sort data (lambda (a b)
;; (> (string->number (caddr a))(string->number (caddr b)))))))
;; ))
(sort all-tests sort-fn1))) ;; avoid dealing with deleted tests, look at the hash table
(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")
|