Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -958,21 +958,21 @@ #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) - ;; (print "obj: " obj) + (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 "x\ty\tllx\tlly\turx\tury") + ;; (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 x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " + ;; (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)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -673,11 +673,11 @@ )) (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"))) + (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)))) @@ -693,17 +693,23 @@ (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))) + (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 (equal? (car x) "edge") + (if (and (not (null? x)) + (equal? (car x) "edge")) (equal? hed (cadr x)) #f)) dot-data))) (map (lambda (inlst) (dcommon:process-polyline Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -24,10 +24,11 @@ (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") @@ -792,35 +793,35 @@ (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) + ;; (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") + ;; (debug:print 0 "case1") #t) ((member b a-waitons) ;; is a waiting on b? - (debug:print 0 "case2") + ;; (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") + ;; (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") + ;; (debug:print 0 "case3") #f) ((and (not (null? a-waitons)) ;; a has waitons but b does not (null? b-waitons)) - (debug:print 0 "case4") + ;; (debug:print 0 "case4") #t) ((not (eq? a-priority b-priority)) ;; use (> a-priority b-priority)) (else - (debug:print 0 "case5") + ;; (debug:print 0 "case5") (string>? a b)))))) (sort-fn2 (lambda (a b) (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) @@ -860,11 +861,13 @@ ;; (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)))) + (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) '() @@ -872,38 +875,54 @@ (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? 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 - (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)))) + (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 '()))