Megatest

Check-in [f9a243a4c5]
Login
Overview
Comment:Added support to show the [waitons] section on the Run Control tab.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65
Files: files | file ages | folders
SHA1: f9a243a4c5849427f01c7a9948da14c3c01ad45f
User & Date: mrwellan on 2020-10-20 18:37:57
Other Links: branch diff | manifest | tags
Context
2020-10-20
21:26
Removed noisy print check-in: c1b62ae797 user: mrwellan tags: v1.65
18:37
Added support to show the [waitons] section on the Run Control tab. check-in: f9a243a4c5 user: mrwellan tags: v1.65
2020-10-19
00:22
Rearranged the target for chicken. check-in: c3c27bb923 user: matt tags: v1.65
Changes

Modified tests.scm from [0094b671e6] to [994fb90053].

1699
1700
1701
1702
1703
1704
1705

















1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717



1718
1719
1720
1721

1722
1723
1724
1725
1726
1727
1728
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733

1734
1735
1736
1737
1738
1739

1740
1741
1742
1743
1744
1745
1746
1747







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+











-
+
+
+



-
+







	;;     		  (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

;; look up all waitons that are related to test "testname"
;;
(define (tests:get-mt-waitons testname flatten)
  (let* ((mt-waitons    (configf:get-section *configdat* "waitons"))
	 (my-waitons    (filter
			 (lambda (x)
			   (string-match (conc "^(" testname "|" testname"/.*)$") (car x)))
			 mt-waitons)))
    (if flatten
	(map (lambda (w)
	       (car (string-split w "/")))
	     (apply append (map (lambda (x)
				  (string-split (cadr x)))
				my-waitons)))
	my-waitons)))

;; NOT USED
(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) '())))
		(waitons (or (tests:testqueue-get-waitons testrec) '()))
		(my-mt-waitons (tests:get-mt-waitons testname #t)))
	   ;; (print "my-mt-waitons=" my-mt-waitons)
	   (for-each
	    (lambda (waiton)
	      (format temp-port (conc "   " waiton " -> " testname " [splines=ortho]\n")))
	    waitons)))
	    (append waitons my-mt-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)))
1743
1744
1745
1746
1747
1748
1749


1750
1751

1752
1753
1754
1755

1756

1757
1758
1759
1760
1761
1762
1763
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771

1772
1773
1774
1775

1776

1777
1778
1779
1780
1781
1782
1783
1784







+
+

-
+



-
+
-
+







		   (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) '()))
		 (my-mt-waitons (tests:get-mt-waitons hed #t))
		 (all-waitons   (delete-duplicates (append waitons my-mt-waitons)))
		 (newres  (append res
				  (if (null? waitons)
				  (if (null? all-waitons)
				      (list (conc "   \"" hed "\" [shape=box];"))
				      (map (lambda (waiton)
					     (conc "   \"" waiton "\" -> \"" hed "\" [shape=box];"))
					   waitons)
					   all-waitons)))))
				      ))))
	    (debug:print 0 *default-log-port* "For test "hed" got "all-waitons)
	    (if (null? tal)
		(append newres (list "}"))
		(loop (car tal)(cdr tal) newres)
		))))))

;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")