Overview
| Comment: | Added lazy-dot |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.60 |
| Files: | files | file ages | folders |
| SHA1: |
4c9bcc5748c6fc9670615c7eaaf6879b |
| 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 | )) ;; #:size "50x50" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) | | | | | 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 |
;; (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)))
| | | > | | | | > > > > > | | 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 | (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) | | | | | | | | | 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 |
(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))
| > > | > > | | | > < < | < | | | | < | | | < | > | > > | > > > > > > > > > | > > > > > > | 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)
|
| ︙ | ︙ |