@@ -17,10 +17,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) +(include "common.scm") (include "margs.scm") (include "keys.scm") (include "items.scm") (include "db.scm") (include "configf.scm") @@ -48,12 +49,15 @@ (define remargs (args:get-args (argv) (list "-rows" "-run" "-test" + "-debug" ) (list "-h" + "-v" + "-q" ) args:arg-hash 0)) (if (args:get-arg "-h") @@ -75,20 +79,76 @@ (define dbkeys (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) (define *buttondat* (make-hash-table)) ;; -(define *alltestnames* (make-hash-table)) ;; build a minimalized list of test names (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 10) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) (define *examine-test-dat* (make-hash-table)) (define *exit-started* #f) +(define *verbosity* (cond + ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1))) + +(define uidat #f) +;; (megatest-dashboard) + +;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector +; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 +; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 +; 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 +; 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 +; 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 +; 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 +; 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 +; 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 +; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0 +; 2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2 +; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 +; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0 +; 2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1)))) +; +;(define img2 (iup:image/palette 16 16 (u8vector->blob (u8vector +; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 +; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 +; 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 +; 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 +; 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 +; 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 +; 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 +; 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 +; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 +; 2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0 +; 2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2 +; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 +; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0 +; 2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1)))) +; +;(iup:handle-name-set! img1 "img1") +;(iup:attribute-set! img1 "0" "0 0 0") +;(iup:attribute-set! img1 "1" "BGCOLOR") +;(iup:attribute-set! img1 "2" "255 0 0") +; +;(iup:handle-name-set! img2 "img2") +;(iup:attribute-set! img2 "0" "0 0 0") +;(iup:attribute-set! img2 "1" "BGCOLOR") +;(iup:attribute-set! img2 "2" "255 0 0") + (define (message-window msg) (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) @@ -130,10 +190,55 @@ runs) (set! *header* header) (set! *allruns* result) maxtests)) +(define *collapsed* (make-hash-table)) +; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) + +(define (toggle-hide lnum) ; fulltestname) + (let* ((btn (vector-ref (vector-ref uidat 0) lnum)) + (fulltestname (iup:attribute btn "TITLE")) + (parts (string-split fulltestname "(")) + (basetestname (if (null? parts) "" (car parts)))) + ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) + (if (hash-table-ref/default *collapsed* basetestname #f) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") + (hash-table-delete! *collapsed* basetestname)) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") + (hash-table-set! *collapsed* basetestname #t))))) + +(define blank-line-rx (regexp "^\\s*$")) + +(define (collapse-rows inlst) + (let ((newlst (filter (lambda (x) + (let* ((tparts (string-split x "(")) + (basetname (if (null? tparts) x (car tparts)))) + ;(print "x " x " tparts: " tparts " basetname: " basetname) + (cond + ((string-match blank-line-rx x) #f) + ((equal? x basetname) #t) + ((hash-table-ref/default *collapsed* basetname #f) + ;(print "Removing " basetname " from items") + #f) + (else #t)))) + inlst))) + ;; special sort to push the test(item) to after test + (sort newlst (lambda (a b) + (let* ((partsa (string-split a "(")) + (partsb (string-split b "(")) + (lena (length partsa)) + (lenb (length partsb))) + (if (or (and (eq? lena 1)(> lenb 1)) + (and (eq? lenb 1)(> lena 1))) + (if (equal? (car partsa)(car partsb)) ;; same test + (> lenb lena) + #t) + #t)))))) + (define (update-labels uidat) (let* ((rown 0) (lftcol (vector-ref uidat 0)) (numcols (vector-length lftcol)) (maxn (- numcols 1)) @@ -141,19 +246,21 @@ (for-each (lambda (name) (if (<= rown maxn) (let ((labl (vector-ref lftcol rown))) (vector-set! allvals rown name))) (set! rown (+ 1 rown))) - (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) - '())) + *alltestnamelst*) + ; (if (> (length *alltestnamelst*) *start-test-offset*) + ; (drop *alltestnamelst* *start-test-offset*) + ; '())) (let loop ((i 0)) (let* ((lbl (vector-ref lftcol i)) (oldval (iup:attribute lbl "TITLE")) (newval (vector-ref allvals i))) (if (not (equal? oldval newval)) (iup:attribute-set! lbl "TITLE" newval)) + (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) (define (get-color-for-state-status state status) (case (string->symbol state) @@ -179,55 +286,44 @@ (pad-list *allruns* numruns))) (lftcol (vector-ref uidat 0)) (tableheader (vector-ref uidat 1)) (table (vector-ref uidat 2)) (coln 0)) - (update-labels uidat) - (for-each - (lambda (popup) - (let* ((test-id (car popup)) - (widgets (hash-table-ref *examine-test-dat* popup)) - (stepslbl (hash-table-ref/default widgets "Test Steps" #f))) - (if stepslbl - (let* ((fmtstr "~15a~8a~8a~20a") - (newtxt (string-intersperse - (append - (list - (format #f fmtstr "Stepname" "State" "Status" "Event Time") - (format #f fmtstr "========" "=====" "======" "==========")) - (map (lambda (x) - ;; take advantage of the \n on time->string - (format #f fmtstr - (db:step-get-stepname x) - (db:step-get-state x) - (db:step-get-status x) - (time->string - (seconds->local-time - (db:step-get-event_time x))))) - (db-get-test-steps-for-run *db* test-id))) - "\n"))) - (iup:attribute-set! stepslbl "TITLE" newtxt))))) - (hash-table-keys *examine-test-dat*)) (set! *alltestnamelst* '()) + ;; create a concise list of test names + (for-each (lambda (rundat) + (if (vector? rundat) + (let* ((testdat (vector-ref rundat 1)) + (testnames (map test:test-get-fullname testdat))) + (for-each (lambda (testname) + (if (not (member testname *alltestnamelst*)) + (begin + (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) + testnames)))) + runs) + + (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) + (drop *alltestnamelst* *start-test-offset*) + '()))) + (append xl (make-list (- *num-tests* (length xl)) "")))) + (update-labels uidat) (for-each (lambda (rundat) (if (not rundat) ;; handle padded runs ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) (let* ((run (vector-ref rundat 0)) (testsdat (vector-ref rundat 1)) (key-val-dat (vector-ref rundat 2)) (run-id (db:get-value-by-header run *header* "id")) - (testnames (delete-duplicates (append *alltestnamelst* - (map test:test-get-fullname testsdat)))) ;; (take (pad-list testsdat numtests) numtests)) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run *header* "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n"))) - ;; (run-ht (hash-table-ref/default alldat run-key #f))) + ;; fill in the run header key values - (set! *alltestnamelst* testnames) (let ((rown 0) (headercol (vector-ref tableheader coln))) (for-each (lambda (kval) (let* ((labl (vector-ref headercol rown))) (if (not (equal? kval (iup:attribute labl "TITLE"))) @@ -246,11 +342,10 @@ (lambda (x)(equal? (test:test-get-fullname x) testname)) testsdat))) (if (null? matching) (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") (car matching)))) - ;; (test (if real-test real-test (testname (db:test-get-testname test)) (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) @@ -259,32 +354,21 @@ (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) (button (vector-ref columndat rown)) (color (get-color-for-state-status teststate teststatus)) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - ;; (if (and (equal? teststate "RUNNING") - ;; (> (- (current-seconds) (+ teststart runtime)) 100)) ;; if test has been dead for more than 100 seconds, call it dead - (if (not (equal? curr-color color)) (iup:attribute-set! button "BGCOLOR" color)) (if (not (equal? curr-title buttontxt)) (iup:attribute-set! button "TITLE" buttontxt)) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 test) - (vector-set! buttondat 4 run-key) - (if (not (hash-table-ref/default *alltestnames* testfullname #f)) - (begin - (hash-table-set! *alltestnames* testfullname #t) - (set! *alltestnamelst* (append *alltestnamelst* (list testfullname)))))) - ) + (vector-set! buttondat 4 run-key))) (set! rown (+ rown 1)))) - (let ((xl (if (> (length testnames) *start-test-offset*) - (drop testnames *start-test-offset*) - '()))) ;; testnames))) - (append xl (make-list (- *num-tests* (length xl)) ""))))) + *alltestnamelst*)) (set! coln (+ coln 1)))) runs))) (define (mkstr . x) (string-intersperse (map conc x) ",")) @@ -339,11 +423,18 @@ (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (apply iup:vbox (reverse res)))))) (else - (let ((labl (iup:button "" #:flat "YES" #:size "100x15" #:fontsize "10"))) + (let ((labl (iup:button "" + #:flat "YES" + ; #:image img1 + ; #:impress img2 + #:size "100x15" + #:fontsize "10" + #:action (lambda (obj) + (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE")))) (vector-set! lftcol testnum labl) (loop (+ testnum 1)(cons labl res)))))) ;; (let loop ((runnum 0) (keynum 0) @@ -354,12 +445,11 @@ ((>= keynum nkeys) (vector-set! header runnum keyvec) (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) (loop (+ runnum 1) 0 (make-vector nkeys) '())) (else - (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" ;; #:expand "HORIZONTAL" - ))) + (let ((labl (iup:label "" #:size "60x15" #:fontsize "10"))) ;; #:expand "HORIZONTAL" (vector-set! keyvec keynum labl) (loop runnum (+ keynum 1) keyvec (cons labl res)))))) ;; By here the hdrlst contains a list of vboxes containing nkeys labels (let loop ((runnum 0) (testnum 0) @@ -380,11 +470,11 @@ #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (cmd (conc toolpath " -test " test-id "&"))) - (print "Launching " cmd) + ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog @@ -408,13 +498,10 @@ (set! *num-tests* (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS")))) (update-rundat "%" *num-runs* "%" "%")) (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%" "%") 8) 20))) -(define uidat #f) -;; (megatest-dashboard) - (define (run-update mtx1) (let loop ((i 0)) (thread-sleep! 0.05) (mutex-lock! mtx1) (update-buttons uidat *num-runs* *num-tests*)