Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -877,10 +877,11 @@ ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests ;; + (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) (test-names (hash-table-keys all-tests-registry)) @@ -908,252 +909,342 @@ (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys (iup:vbox - ;; The command line display/exectution control - (iup:frame - #:title "Command to be exectuted" - (iup:hbox - (iup:label "Run on" #:size "40x") - (iup:radio - (iup:hbox - (iup:toggle "Local" #:size "40x") - (iup:toggle "Server" #:size "40x"))) - (let ((tb (iup:textbox - #:value "megatest " - #:expand "HORIZONTAL" - #:readonly "YES" - #:font "Courier New, -12" - ))) - (dboard:data-set-command-tb! *data* tb) - tb) - (iup:button "Execute" #:size "50x" - #:action (lambda (obj) - (let ((cmd (conc "xterm -geometry 180x20 -e \"" - (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") - ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd)))))) - + (dcommon:command-execution-control *data*) + (iup:split + #:orientation "HORIZONTAL" + + (iup:split + #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector *data*) + (dcommon:command-runname-selector *alldat* *data*) + (dcommon:command-testname-selector *alldat* *data* update-keyvals key-listboxes)) + + (dcommon:command-tests-tasks-canvas *data* test-records sorted-testnames tests-draw-state)) + + (iup:frame + #:title "Logs" ;; To be replaced with tabs + (let ((logs-tb (iup:textbox #:expand "YES" + #:multiline "YES"))) + (dboard:data-set-logs-textbox! *data* logs-tb) + logs-tb)))))) +;; +;; (define (dashboard:run-controls) +;; (let* ((targets (make-hash-table)) +;; (test-records (make-hash-table)) +;; (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) +;; (test-names (hash-table-keys all-tests-registry)) +;; (sorted-testnames #f) +;; (action "-run") +;; (cmdln "") +;; (runlogs (make-hash-table)) +;; (key-listboxes #f) +;; (updater-for-runs #f) +;; (update-keyvals (lambda () +;; (let ((targ (map (lambda (x) +;; (iup:attribute x "VALUE")) +;; (car (dashboard:update-target-selector key-listboxes)))) +;; (curr-runname (dboard:data-get-run-name *data*))) +;; (dboard:data-set-target! *data* targ) +;; (if updater-for-runs (updater-for-runs)) +;; (if (or (not (equal? curr-runname (dboard:data-get-run-name *data*))) +;; (equal? (dboard:data-get-run-name *data*) "")) +;; (dboard:data-set-run-name! *data* curr-runname)) +;; (dashboard:update-run-command)))) +;; (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas +;; (test-patterns-textbox #f)) +;; (hash-table-set! tests-draw-state 'first-time #t) +;; ;; (hash-table-set! tests-draw-state 'scalef 1) +;; (tests:get-full-data test-names test-records '() all-tests-registry) +;; (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) +;; +;; ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys +;; (iup:vbox +;; ;; The command line display/exectution control +;; (iup:frame +;; #:title "Command to be exectuted" +;; (iup:hbox +;; (iup:label "Run on" #:size "40x") +;; (iup:radio +;; (iup:hbox +;; (iup:toggle "Local" #:size "40x") +;; (iup:toggle "Server" #:size "40x"))) +;; (let ((tb (iup:textbox +;; #:value "megatest " +;; #:expand "HORIZONTAL" +;; #:readonly "YES" +;; #:font "Courier New, -12" +;; ))) +;; (dboard:data-set-command-tb! *data* tb) +;; tb) +;; (iup:button "Execute" #:size "50x" +;; #:action (lambda (obj) +;; (let ((cmd (conc "xterm -geometry 180x20 -e \"" +;; (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") +;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) +;; (system cmd)))))) +;; +;; (iup:split +;; #:orientation "HORIZONTAL" +;; +;; (iup:split +;; #:value 300 +;; +;; ;; Target, testpatt, state and status input boxes +;; ;; +;; (iup:vbox +;; ;; Command to run +;; (iup:frame +;; #:title "Set the action to take" +;; (iup:hbox +;; ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") +;; (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) +;; (lb (iup:listbox #:expand "HORIZONTAL" +;; #:dropdown "YES" +;; #:action (lambda (obj val index lbstate) +;; ;; (print obj " " val " " index " " lbstate) +;; (dboard:data-set-command! *data* val) +;; (dashboard:update-run-command)))) +;; (default-cmd (car cmds-list))) +;; (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) +;; (dboard:data-set-command! *data* default-cmd) +;; lb))) +;; +;; (iup:frame +;; #:title "Runname" +;; (let* ((default-run-name (seconds->work-week/day (current-seconds))) +;; (tb (iup:textbox #:expand "HORIZONTAL" +;; #:action (lambda (obj val txt) +;; ;; (print "obj: " obj " val: " val " unk: " unk) +;; (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) +;; (dashboard:update-run-command)) +;; #:value (or default-run-name (dboard:data-get-run-name *data*)))) +;; (lb (iup:listbox #:expand "HORIZONTAL" +;; #:dropdown "YES" +;; #:action (lambda (obj val index lbstate) +;; (if (not (equal? val "")) +;; (begin +;; (iup:attribute-set! tb "VALUE" val) +;; (dboard:data-set-run-name! *data* val) +;; (dashboard:update-run-command)))))) +;; (refresh-runs-list (lambda () +;; (let* ((target (dboard:data-get-target-string *data*)) +;; (runs-for-targ (if (d:alldat-useserver *alldat*) +;; (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f) +;; (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f))) +;; (runs-header (vector-ref runs-for-targ 0)) +;; (runs-dat (vector-ref runs-for-targ 1)) +;; (run-names (cons default-run-name +;; (map (lambda (x) +;; (db:get-value-by-header x runs-header "runname")) +;; runs-dat)))) +;; ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") +;; (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) +;; (set! updater-for-runs refresh-runs-list) +;; (refresh-runs-list) +;; (dboard:data-set-run-name! *data* default-run-name) +;; (iup:hbox +;; tb +;; lb))) +;; +;; (iup:frame +;; #:title "SELECTORS" +;; (iup:vbox +;; ;; Text box for test patterns +;; (iup:frame +;; #:title "Test patterns (one per line)" +;; (let ((tb (iup:textbox #:action (lambda (val a b) +;; (dboard:data-set-test-patts! +;; *data* +;; (dboard:lines->test-patt b)) +;; (dashboard:update-run-command)) +;; #:value (dboard:test-patt->lines +;; (dboard:data-get-test-patts *data*)) +;; #:expand "YES" +;; #:size "x50" +;; #:multiline "YES"))) +;; (set! test-patterns-textbox tb) +;; tb)) +;; (iup:frame +;; #:title "Target" +;; ;; Target selectors +;; (apply iup:hbox +;; (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) +;; (key-lb (car dat)) +;; (combos (cadr dat))) +;; (set! key-listboxes key-lb) +;; combos))) +;; (iup:hbox +;; ;; Text box for STATES +;; (iup:frame +;; #:title "States" +;; (dashboard:text-list-toggle-box +;; ;; Move these definitions to common and find the other useages and replace! +;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") +;; (lambda (all) +;; (dboard:data-set-states! *data* all) +;; (dashboard:update-run-command)))) +;; ;; Text box for STATES +;; (iup:frame +;; #:title "Statuses" +;; (dashboard:text-list-toggle-box +;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") +;; (lambda (all) +;; (dboard:data-set-statuses! *data* all) +;; (dashboard:update-run-command)))))))) +;; +;; (iup:frame +;; #:title "Tests and Tasks" +;; (let* ((updater #f) +;; (last-xadj 0) +;; (last-yadj 0) +;; (the-cnv #f) +;; (canvas-obj +;; (iup:canvas #:action (make-canvas-action +;; (lambda (cnv xadj yadj) +;; (if (not updater) +;; (set! updater (lambda (xadj yadj) +;; ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) +;; (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) +;; (set! last-xadj xadj) +;; (set! last-yadj yadj)))) +;; (updater xadj yadj) +;; (set! the-cnv cnv) +;; )) +;; ;; Following doesn't work +;; #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. +;; (let ((scalef (hash-table-ref tests-draw-state 'scalef))) +;; (hash-table-set! tests-draw-state 'scalef (+ scalef +;; (if (> step 0) +;; (* scalef 0.01) +;; (* scalef -0.01)))) +;; (if the-cnv +;; (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) +;; )) +;; ;; #: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) +;; ; (print "canvas-origin: " (canvas-origin the-cnv)) +;; ;; (let-values (((xx yy)(canvas-origin the-cnv))) +;; ;; (canvas-transform-set! the-cnv #f) +;; ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) +;; (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) +;; (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) +;; (scalef (hash-table-ref tests-draw-state 'scalef)) +;; (sizey (hash-table-ref tests-draw-state 'sizey)) +;; (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) +;; (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) +;; (new-y (- sizey y))) +;; ;; (print "xoffset=" xoffset ", yoffset=" yoffset) +;; ;; (print "\tx\ty\tllx\tlly\turx\tury") +;; (for-each (lambda (test-name) +;; (let* ((rec-coords (hash-table-ref tests-info test-name)) +;; (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) +;; (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) +;; (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) +;; (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) +;; ;; (if (eq? pressed 1) +;; ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) +;; (if (and (eq? pressed 1) +;; (>= x llx) +;; (>= new-y lly) +;; (<= x urx) +;; (<= new-y ury)) +;; (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) +;; (let* ((selected (not (member test-name patterns))) +;; (newpatt-list (if selected +;; (cons test-name patterns) +;; (delete test-name patterns))) +;; (newpatt (string-intersperse newpatt-list "\n"))) +;; (iup:attribute-set! obj "REDRAW" "ALL") +;; (hash-table-set! selected-tests test-name selected) +;; (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) +;; (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) +;; (dashboard:update-run-command) +;; (if updater (updater last-xadj last-yadj))))))) +;; (hash-table-keys tests-info))))))) +;; canvas-obj))) +;; +;; (iup:frame +;; #:title "Logs" ;; To be replaced with tabs +;; (let ((logs-tb (iup:textbox #:expand "YES" +;; #:multiline "YES"))) +;; (dboard:data-set-logs-textbox! *data* logs-tb) +;; logs-tb)))))) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:run-times) + (let* ((targets (make-hash-table)) + (test-records (make-hash-table)) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (test-names (hash-table-keys all-tests-registry)) + (sorted-testnames #f) + (action "-run") + (cmdln "") + (runlogs (make-hash-table)) + (key-listboxes #f) + (updater-for-runs #f) + (update-keyvals (lambda () + (let ((targ (map (lambda (x) + (iup:attribute x "VALUE")) + (car (dashboard:update-target-selector key-listboxes)))) + (curr-runname (dboard:data-get-run-name *data*))) + (dboard:data-set-target! *data* targ) + (if updater-for-runs (updater-for-runs)) + (if (or (not (equal? curr-runname (dboard:data-get-run-name *data*))) + (equal? (dboard:data-get-run-name *data*) "")) + (dboard:data-set-run-name! *data* curr-runname)) + (dashboard:update-run-command)))) + (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas + (test-patterns-textbox #f)) + (hash-table-set! tests-draw-state 'first-time #t) + ;; (hash-table-set! tests-draw-state 'scalef 1) + (tests:get-full-data test-names test-records '() all-tests-registry) + (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) + + ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys + (iup:vbox + (dcommon:command-execution-control *data*) (iup:split #:orientation "HORIZONTAL" (iup:split #:value 300 ;; Target, testpatt, state and status input boxes ;; (iup:vbox - ;; Command to run - (iup:frame - #:title "Set the action to take" - (iup:hbox - ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - ;; (print obj " " val " " index " " lbstate) - (dboard:data-set-command! *data* val) - (dashboard:update-run-command)))) - (default-cmd (car cmds-list))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (dboard:data-set-command! *data* default-cmd) - lb))) - - (iup:frame - #:title "Runname" - (let* ((default-run-name (seconds->work-week/day (current-seconds))) - (tb (iup:textbox #:expand "HORIZONTAL" - #:action (lambda (obj val txt) - ;; (print "obj: " obj " val: " val " unk: " unk) - (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) - (dashboard:update-run-command)) - #:value (or default-run-name (dboard:data-get-run-name *data*)))) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (if (not (equal? val "")) - (begin - (iup:attribute-set! tb "VALUE" val) - (dboard:data-set-run-name! *data* val) - (dashboard:update-run-command)))))) - (refresh-runs-list (lambda () - (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f) - (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f))) - (runs-header (vector-ref runs-for-targ 0)) - (runs-dat (vector-ref runs-for-targ 1)) - (run-names (cons default-run-name - (map (lambda (x) - (db:get-value-by-header x runs-header "runname")) - runs-dat)))) - ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") - (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) - (set! updater-for-runs refresh-runs-list) - (refresh-runs-list) - (dboard:data-set-run-name! *data* default-run-name) - (iup:hbox - tb - lb))) - - (iup:frame - #:title "SELECTORS" - (iup:vbox - ;; Text box for test patterns - (iup:frame - #:title "Test patterns (one per line)" - (let ((tb (iup:textbox #:action (lambda (val a b) - (dboard:data-set-test-patts! - *data* - (dboard:lines->test-patt b)) - (dashboard:update-run-command)) - #:value (dboard:test-patt->lines - (dboard:data-get-test-patts *data*)) - #:expand "YES" - #:size "x50" - #:multiline "YES"))) - (set! test-patterns-textbox tb) - tb)) - (iup:frame - #:title "Target" - ;; Target selectors - (apply iup:hbox - (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) - (key-lb (car dat)) - (combos (cadr dat))) - (set! key-listboxes key-lb) - combos))) - (iup:hbox - ;; Text box for STATES - (iup:frame - #:title "States" - (dashboard:text-list-toggle-box - ;; Move these definitions to common and find the other useages and replace! - (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") - (lambda (all) - (dboard:data-set-states! *data* all) - (dashboard:update-run-command)))) - ;; Text box for STATES - (iup:frame - #:title "Statuses" - (dashboard:text-list-toggle-box - (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") - (lambda (all) - (dboard:data-set-statuses! *data* all) - (dashboard:update-run-command)))))))) - - (iup:frame - #:title "Tests and Tasks" - (let* ((updater #f) - (last-xadj 0) - (last-yadj 0) - (the-cnv #f) - (canvas-obj - (iup:canvas #:action (make-canvas-action - (lambda (cnv xadj yadj) - (if (not updater) - (set! updater (lambda (xadj yadj) - ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) - (set! last-xadj xadj) - (set! last-yadj yadj)))) - (updater xadj yadj) - (set! the-cnv cnv) - )) - ;; Following doesn't work - #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (let ((scalef (hash-table-ref tests-draw-state 'scalef))) - (hash-table-set! tests-draw-state 'scalef (+ scalef - (if (> step 0) - (* scalef 0.01) - (* scalef -0.01)))) - (if the-cnv - (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) - )) - ;; #: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) - ; (print "canvas-origin: " (canvas-origin the-cnv)) - ;; (let-values (((xx yy)(canvas-origin the-cnv))) - ;; (canvas-transform-set! the-cnv #f) - ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) - (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) - (scalef (hash-table-ref tests-draw-state 'scalef)) - (sizey (hash-table-ref tests-draw-state 'sizey)) - (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) - (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) - (new-y (- sizey y))) - ;; (print "xoffset=" xoffset ", yoffset=" yoffset) - ;; (print "\tx\ty\tllx\tlly\turx\tury") - (for-each (lambda (test-name) - (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) - (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) - (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) - (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) - ;; (if (eq? pressed 1) - ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) - (if (and (eq? pressed 1) - (>= x llx) - (>= new-y lly) - (<= x urx) - (<= new-y ury)) - (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) - (let* ((selected (not (member test-name patterns))) - (newpatt-list (if selected - (cons test-name patterns) - (delete test-name patterns))) - (newpatt (string-intersperse newpatt-list "\n"))) - (iup:attribute-set! obj "REDRAW" "ALL") - (hash-table-set! selected-tests test-name selected) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command) - (if updater (updater last-xadj last-yadj))))))) - (hash-table-keys tests-info))))))) - canvas-obj))) - + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector *data*) + (dcommon:command-runname-selector *alldat* *data*) + (dcommon:command-testname-selector *alldat* *data* update-keyvals key-listboxes)) + + (dcommon:command-tests-tasks-canvas *data* test-records sorted-testnames tests-draw-state)) + (iup:frame #:title "Logs" ;; To be replaced with tabs (let ((logs-tb (iup:textbox #:expand "YES" #:multiline "YES"))) (dboard:data-set-logs-textbox! *data* logs-tb) logs-tb)))))) - -;; (trace dashboard:populate-target-dropdown -;; common:list-is-sublist) -;; -;; ;; key1 key2 key3 ... -;; ;; target entry (wild cards allowed) -;; -;; ;; The action -;; (iup:hbox -;; ;; label Action | action selector -;; )) -;; ;; Test/items selector -;; (iup:hbox -;; ;; tests -;; ;; items -;; )) -;; ;; The command line -;; (iup:hbox -;; ;; commandline entry -;; ;; GO button -;; ) -;; ;; The command log monitor -;; (iup:tabs -;; ;; log monitor -;; ))) - ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area @@ -1763,11 +1854,11 @@ ;; (run-id (db:test-get-run_id (vector-ref buttndat 3))) ;; (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;; ;(print "Launching " cmd) ;; (system cmd))) #:button-cb (lambda (obj a pressed x y btn . rem) - (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) + ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) (if (eq? pressed 1) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) @@ -1793,24 +1884,28 @@ (iup:menu-item "Edit testconfig" #:action (lambda (obj) (let* ((all-tests (tests:get-all)) - (editor (or (get-environment-variable "VISUAL") + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") (get-environment-variable "EDITOR") "gvim")) (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) - (cmd (conc (if (string-search "\\b(vim?|nano|pico)\\b") + (cmd (conc (if (string-search editor-rx editor) (conc "xterm -e " editor) editor) " " tconfig))) (system cmd)))) ))))) (iup:show popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") - (print "got here"))) + ;; (print "got here") + )) (if (eq? pressed 0) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) @@ -1843,16 +1938,18 @@ (dashboard:summary *alldat*) runs-view (dashboard:one-run db data runs-sum-dat) ;; (dashboard:new-view db data new-view-dat) (dashboard:run-controls) + (dashboard:run-times) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") + (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") (iup:attribute-set! tabs "BGCOLOR" "190 190 190") (d:alldat-hide-not-hide-tabs-set! *alldat* tabs) (iup:vbox Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -11,10 +11,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) +(import canvas-draw-iup) (use regex defstruct) (declare (unit dcommon)) (declare (uses megatest-version)) @@ -900,10 +901,218 @@ (dcommon:draw-edges cnv xoffset yoffset scalef edges) (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) + +;;====================================================================== +;; RUN CONTROLS +;;====================================================================== + +(define (dcommon:command-execution-control data) + ;; The command line display/exectution control + (iup:frame + #:title "Command to be exectuted" + (iup:hbox + (iup:label "Run on" #:size "40x") + (iup:radio + (iup:hbox + (iup:toggle "Local" #:size "40x") + (iup:toggle "Server" #:size "40x"))) + (let ((tb (iup:textbox + #:value "megatest " + #:expand "HORIZONTAL" + #:readonly "YES" + #:font "Courier New, -12" + ))) + (dboard:data-set-command-tb! data tb) + tb) + (iup:button "Execute" #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc "xterm -geometry 180x20 -e \"" + (iup:attribute (dboard:data-get-command-tb data) "VALUE") + ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd))))))) + +(define (dcommon:command-action-selector data) + (iup:frame + #:title "Set the action to take" + (iup:hbox + ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") + (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + ;; (print obj " " val " " index " " lbstate) + (dboard:data-set-command! data val) + (dashboard:update-run-command)))) + (default-cmd (car cmds-list))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (dboard:data-set-command! data default-cmd) + lb)))) + +(define (dcommon:command-runname-selector alldat data) + (iup:frame + #:title "Runname" + (let* ((default-run-name (seconds->work-week/day (current-seconds))) + (tb (iup:textbox #:expand "HORIZONTAL" + #:action (lambda (obj val txt) + ;; (print "obj: " obj " val: " val " unk: " unk) + (dboard:data-set-run-name! data txt) ;; (iup:attribute obj "VALUE")) + (dashboard:update-run-command)) + #:value (or default-run-name (dboard:data-get-run-name data)))) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (if (not (equal? val "")) + (begin + (iup:attribute-set! tb "VALUE" val) + (dboard:data-set-run-name! data val) + (dashboard:update-run-command)))))) + (refresh-runs-list (lambda () + (let* ((target (dboard:data-get-target-string data)) + (runs-for-targ (if (d:alldat-useserver alldat) + (rmt:get-runs-by-patt (d:alldat-keys alldat) "%" target #f #f #f) + (db:get-runs-by-patt (d:alldat-dblocal alldat) (d:alldat-keys alldat) "%" target #f #f #f))) + (runs-header (vector-ref runs-for-targ 0)) + (runs-dat (vector-ref runs-for-targ 1)) + (run-names (cons default-run-name + (map (lambda (x) + (db:get-value-by-header x runs-header "runname")) + runs-dat)))) + ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") + (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) + (set! updater-for-runs refresh-runs-list) + (refresh-runs-list) + (dboard:data-set-run-name! *data* default-run-name) + (iup:hbox + tb + lb)))) + +(define (dcommon:command-testname-selector alldat data update-keyvals key-listboxes) + (iup:frame + #:title "SELECTORS" + (iup:vbox + ;; Text box for test patterns + (iup:frame + #:title "Test patterns (one per line)" + (let ((tb (iup:textbox #:action (lambda (val a b) + (dboard:data-set-test-patts! + *data* + (dboard:lines->test-patt b)) + (dashboard:update-run-command)) + #:value (dboard:test-patt->lines + (dboard:data-get-test-patts *data*)) + #:expand "YES" + #:size "x50" + #:multiline "YES"))) + (set! test-patterns-textbox tb) + tb)) + (iup:frame + #:title "Target" + ;; Target selectors + (apply iup:hbox + (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) + (key-lb (car dat)) + (combos (cadr dat))) + (set! key-listboxes key-lb) + combos))) + (iup:hbox + ;; Text box for STATES + (iup:frame + #:title "States" + (dashboard:text-list-toggle-box + ;; Move these definitions to common and find the other useages and replace! + (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + (lambda (all) + (dboard:data-set-states! *data* all) + (dashboard:update-run-command)))) + ;; Text box for STATES + (iup:frame + #:title "Statuses" + (dashboard:text-list-toggle-box + (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + (lambda (all) + (dboard:data-set-statuses! *data* all) + (dashboard:update-run-command)))))))) + +(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state) + (iup:frame + #:title "Tests and Tasks" + (let* ((updater #f) + (last-xadj 0) + (last-yadj 0) + (the-cnv #f) + (canvas-obj + (iup:canvas #:action (make-canvas-action + (lambda (cnv xadj yadj) + (if (not updater) + (set! updater (lambda (xadj yadj) + ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (set! last-xadj xadj) + (set! last-yadj yadj)))) + (updater xadj yadj) + (set! the-cnv cnv) + )) + ;; Following doesn't work + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (let ((scalef (hash-table-ref tests-draw-state 'scalef))) + (hash-table-set! tests-draw-state 'scalef (+ scalef + (if (> step 0) + (* scalef 0.01) + (* scalef -0.01)))) + (if the-cnv + (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) + )) + ;; #: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) + ; (print "canvas-origin: " (canvas-origin the-cnv)) + ;; (let-values (((xx yy)(canvas-origin the-cnv))) + ;; (canvas-transform-set! the-cnv #f) + ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) + (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) + (scalef (hash-table-ref tests-draw-state 'scalef)) + (sizey (hash-table-ref tests-draw-state 'sizey)) + (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) + (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) + (new-y (- sizey y))) + ;; (print "xoffset=" xoffset ", yoffset=" yoffset) + ;; (print "\tx\ty\tllx\tlly\turx\tury") + (for-each (lambda (test-name) + (let* ((rec-coords (hash-table-ref tests-info test-name)) + (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) + (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) + (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) + (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) + ;; (if (eq? pressed 1) + ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) + (if (and (eq? pressed 1) + (>= x llx) + (>= new-y lly) + (<= x urx) + (<= new-y ury)) + (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((selected (not (member test-name patterns))) + (newpatt-list (if selected + (cons test-name patterns) + (delete test-name patterns))) + (newpatt (string-intersperse newpatt-list "\n"))) + (iup:attribute-set! obj "REDRAW" "ALL") + (hash-table-set! selected-tests test-name selected) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) + (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command) + (if updater (updater last-xadj last-yadj))))))) + (hash-table-keys tests-info))))))) + canvas-obj))) ;;====================================================================== ;; S T E P S ;;======================================================================