Megatest

Check-in [4c9bcc5748]
Login
Overview
Comment:Added lazy-dot
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: 4c9bcc5748c6fc9670615c7eaaf6879b29de608d
User & Date: matt on 2015-10-14 22:19:31
Other Links: branch diff | manifest | tags
Context
2015-10-14
22:31
Added lazy-dot check-in: 3369e3bfa0 user: matt tags: v1.60
22:19
Added lazy-dot check-in: 4c9bcc5748 user: matt tags: v1.60
09:34
Added -local switch to enable local access for some features check-in: 853ef3d17a user: mrwellan tags: v1.60
Changes

Modified dashboard.scm from [eaa2d9a7a5] to [cece23bcce].

956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
					   ))
			    ;; #:size "50x50"
			    #:expand "YES"
			    #:scrollbar "YES"
			    #:posx "0.5"
			    #:posy "0.5"
			    #:button-cb (lambda (obj btn pressed x y status)
					  ;; (print "obj: " obj)
					  (let ((tests-info     (hash-table-ref tests-draw-state  'tests-info))
						(selected-tests (hash-table-ref tests-draw-state  'selected-tests)))
					    ;; (print "x\ty\tllx\tlly\turx\tury")
					    (for-each (lambda (test-name)
							(let* ((rec-coords (hash-table-ref tests-info test-name))
							       (llx        (list-ref rec-coords 0))
							       (urx        (list-ref rec-coords 1))
							       (lly        (list-ref rec-coords 2))
							       (ury        (list-ref rec-coords 3)))
							  ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
							  (if (and (eq? pressed 1)
								   (> x llx)
								   (> y lly)
								   (< x urx)
								   (< y ury))
							      (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
								(let* ((selected     (not (member test-name patterns)))







|


|






|







956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
					   ))
			    ;; #:size "50x50"
			    #:expand "YES"
			    #:scrollbar "YES"
			    #:posx "0.5"
			    #:posy "0.5"
			    #:button-cb (lambda (obj btn pressed x y status)
					  (print "obj: " obj ", pressed " pressed ", status " status)
					  (let ((tests-info     (hash-table-ref tests-draw-state  'tests-info))
						(selected-tests (hash-table-ref tests-draw-state  'selected-tests)))
					    ;; (print "\tx\ty\tllx\tlly\turx\tury")
					    (for-each (lambda (test-name)
							(let* ((rec-coords (hash-table-ref tests-info test-name))
							       (llx        (list-ref rec-coords 0))
							       (urx        (list-ref rec-coords 1))
							       (lly        (list-ref rec-coords 2))
							       (ury        (list-ref rec-coords 3)))
							  ;; (print "\t" x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " ")
							  (if (and (eq? pressed 1)
								   (> x llx)
								   (> y lly)
								   (< x urx)
								   (< y ury))
							      (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
								(let* ((selected     (not (member test-name patterns)))

Modified dcommon.scm from [4f170e6a34] to [5d1caffec5].

671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698

699
700
701
702




703

704
705
706
707
708
709
710
711
    ;; (debug:print 0 "test-box-info=" test-box-info)
    ;; (debug:print 0 "test-record=" test-record)
    ))

(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((dot-data ;; (map cdr (filter
		   ;; 	  (lambda (x)(equal? "node" (car x)))
	  (map string-split (tests:easy-dot test-records "plain")))
	 (scalef (hash-table-ref   tests-draw-state 'scalef))
	 (dotscale (hash-table-ref tests-draw-state 'dotscale))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) 1 (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) 1 (- yadj 0.5))))
	 (boxw   10)
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    ;; (print "dot-data=" dot-data)
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (let ((longest-str   (if (null? sorted-testnames) "         " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
      (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
	(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
    ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((nodedat (car (filter (lambda (x)

					 (if (equal? (car x) "node")
					     (equal? hed (cadr x))
					     #f))
				       dot-data)))




		 (edgedat (let ((edges (filter (lambda (x)  ;; filter for edge

						 (if (equal? (car x) "edge")
						     (equal? hed (cadr x))
						     #f))
					       dot-data)))
			    (map (lambda (inlst)
				   (dcommon:process-polyline 
				    (map (lambda (instr)
					   (* dotscale (string->number instr))) ;; convert to number and scale







|



















|
>
|
|
|
|
>
>
>
>

>
|







671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
    ;; (debug:print 0 "test-box-info=" test-box-info)
    ;; (debug:print 0 "test-record=" test-record)
    ))

(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
  (let* ((dot-data ;; (map cdr (filter
		   ;; 	  (lambda (x)(equal? "node" (car x)))
	  (map string-split (tests:lazy-dot test-records "plain"))) ;; (tests:easy-dot test-records "plain")))
	 (scalef (hash-table-ref   tests-draw-state 'scalef))
	 (dotscale (hash-table-ref tests-draw-state 'dotscale))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) 1 (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) 1 (- yadj 0.5))))
	 (boxw   10)
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    ;; (print "dot-data=" dot-data)
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (let ((longest-str   (if (null? sorted-testnames) "         " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
      (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
	(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
    ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
    (if (not (null? sorted-testnames))
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames))))
	  (let* ((nodedat (let ((tmpres (filter (lambda (x)
						  (if (and (not (null? x))
							   (equal? (car x) "node"))
						      (equal? hed (cadr x))
						      #f))
						dot-data)))
			    (if (null? tmpres)
				;;           llx  lly boxw boxh
				(list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some junk
				(car tmpres))))
		 (edgedat (let ((edges (filter (lambda (x)  ;; filter for edge
						 (if (and (not (null? x))
							  (equal? (car x) "edge"))
						     (equal? hed (cadr x))
						     #f))
					       dot-data)))
			    (map (lambda (inlst)
				   (dcommon:process-polyline 
				    (map (lambda (instr)
					   (* dotscale (string->number instr))) ;; convert to number and scale

Modified tests.scm from [74bec393f0] to [e114fdcd33].

22
23
24
25
26
27
28

29
30
31
32
33
34
35
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))


(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")








>







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
		   (b-config   (tests:testqueue-get-testconfig  b-record))
		   (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		   (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		   (a-priority (mungepriority a-raw-pri))
		   (b-priority (mungepriority b-raw-pri)))
	      (tests:testqueue-set-priority! a-record a-priority)
	      (tests:testqueue-set-priority! b-record b-priority)
	      (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
	      (cond
	       ;; is 
	       ((member a b-waitons)          ;; is b waiting on a?
		(debug:print 0 "case1")
		#t)
	       ((member b a-waitons)          ;; is a waiting on b?
		(debug:print 0 "case2")
		#f)
	       ((and (not (null? a-waitons))  ;; both have waitons - do not disturb
		     (not (null? b-waitons)))
		(debug:print 0 "case2.1")
		#t)
	       ((and (null? a-waitons)        ;; no waitons for a but b has waitons
		     (not (null? b-waitons)))
		(debug:print 0 "case3")
		#f)
	       ((and (not (null? a-waitons))  ;; a has waitons but b does not
		     (null? b-waitons)) 
		(debug:print 0 "case4")
		#t)
	       ((not (eq? a-priority b-priority)) ;; use
		(> a-priority b-priority))
	       (else
		(debug:print 0 "case5")
		(string>? a b))))))
	 
	 (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")))







|



|


|



|



|



|




|







791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
		   (b-config   (tests:testqueue-get-testconfig  b-record))
		   (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		   (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		   (a-priority (mungepriority a-raw-pri))
		   (b-priority (mungepriority b-raw-pri)))
	      (tests:testqueue-set-priority! a-record a-priority)
	      (tests:testqueue-set-priority! b-record b-priority)
	      ;; (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
	      (cond
	       ;; is 
	       ((member a b-waitons)          ;; is b waiting on a?
		;; (debug:print 0 "case1")
		#t)
	       ((member b a-waitons)          ;; is a waiting on b?
		;; (debug:print 0 "case2")
		#f)
	       ((and (not (null? a-waitons))  ;; both have waitons - do not disturb
		     (not (null? b-waitons)))
		;; (debug:print 0 "case2.1")
		#t)
	       ((and (null? a-waitons)        ;; no waitons for a but b has waitons
		     (not (null? b-waitons)))
		;; (debug:print 0 "case3")
		#f)
	       ((and (not (null? a-waitons))  ;; a has waitons but b does not
		     (null? b-waitons)) 
		;; (debug:print 0 "case4")
		#t)
	       ((not (eq? a-priority b-priority)) ;; use
		(> a-priority b-priority))
	       (else
		;; (debug:print 0 "case5")
		(string>? a b))))))
	 
	 (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")))
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
       (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))


      (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


				  (map (lambda (waiton)
					 (conc "   " waiton " -> " hed))
				       waitons))))

	    (if (null? tal)
		(append newres (list "}"))
		(loop (car tal)(cdr tal) newres)
		))))))

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

(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats
  (print "indat: ")
  (map print indat)
  (let-values (((inp oup pid)(process "dot" (list "-T" outtype))))
    (let ((th1 (make-thread (lambda ()
			      (with-output-to-port oup
				(lambda ()
				  (map print indat))))
			    "dot writer")))
      (thread-start! th1)
      (let ((res (with-input-from-port inp
		   (lambda ()
		     (read-lines)))))
	(thread-join! th1)
	(close-input-port inp)

	(close-output-port oup)


	;; (process-wait pid)









	res))))







;; for each test:
;;   
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)







>
>
|











>
>
|
|
|
>








<
<
|
<
|
|
|
|
<
|
|
|
<
|
>
|
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>







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
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
       (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)
		))))))

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

(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats


  (let-values (((inp oup pid)(process "env -i PATH=$PATH dot" (list "-T" outtype))))

    (with-output-to-port oup
      (lambda ()
	(map print indat)))
    (close-output-port oup)

    (let ((res (with-input-from-port inp
		 (lambda ()
		   (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
	  (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname))
	  (with-input-from-file fname
	    (lambda ()
	      (read-lines)))))))
	  

;; for each test:
;;   
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)