Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -337,16 +337,10 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) -(define (dashboard-tests:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) - (if htmlviewercmd - (system (conc "(" htmlviewercmd " " lfilename " ) &")) - (iup:send-url lfilename)))) - (define (dashboard-tests:run-a-step info) #t) (define (dashboard-tests:step-run-control testdat stepname testconfig) (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" @@ -480,18 +474,18 @@ (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer logfile) + (dcommon:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) (if (file-exists? lfilename) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer lfilename) + (dcommon:run-html-viewer lfilename) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -2089,11 +2089,12 @@ (run-id (dboard:tabdat-curr-run-id tabdat)) (run-info (rmt:get-run-info run-id)) (target (rmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (rmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" @@ -2111,18 +2112,18 @@ (system testpanel-cmd)) ((member #\2 status-chars) ;; 2 is middle mouse button (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) - (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) (else (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) - (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) ) @@ -2302,11 +2303,11 @@ #:step 0.01))) ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) ))) -(define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) +(define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) (iup:menu (iup:menu-item "Test Control Panel" #:action (lambda (obj) @@ -2315,13 +2316,37 @@ (conc toolpath " -test " run-id "," test-id " &"))) (system testpanel-cmd) ))) (iup:menu-item - (conc "View Log (not yet implemented) " item-test-path) + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) ) - + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps)))) (iup:menu-item (conc "Rerun " item-test-path) #:action (lambda (obj) (common:run-a-command @@ -2562,11 +2587,12 @@ (run-id (db:test-get-run_id (vector-ref buttndat 3))) (run-info (rmt:get-run-info run-id)) (target (rmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) (testpatt (let ((tlast (rmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" @@ -2574,11 +2600,11 @@ "%"))) (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) - (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu + (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") )) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -1280,5 +1280,16 @@ (loop next-row next-col #t)) (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) + +;;====================================================================== +;; U T I L I T I E S +;;====================================================================== + +(define (dcommon:run-html-viewer lfilename) + (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) + (if htmlviewercmd + (system (conc "(" htmlviewercmd " " lfilename " ) &")) + (iup:send-url lfilename)))) + Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -942,19 +942,21 @@ (for-each (lambda (step) (debug:print 6 *default-log-port* "step=" step) (let ((record (hash-table-ref/default res - (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile Comment - (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) + (tdb:step-get-stepname step) + ;; 0 1 2 3 4 5 6 7 + ;; stepname start end status Duration Logfile Comment first-id + (vector (tdb:step-get-stepname step) "" "" "" "" "" "" #f)))) (debug:print 6 *default-log-port* "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) + (if (not (vector-ref record 7))(vector-set! record 7 (tdb:step-get-id step))) ;; do not clobber the id if previously set (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) @@ -998,34 +1000,38 @@ res)) ;; ;; (define (tests:get-compressed-steps run-id test-id) - (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) - (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) ;; 0 1 2 3 4 5 6 7 + (comprsteps (tests:process-steps-table steps-data))) ;; # (map (lambda (x) ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) + (vector ;; we are constructing basically the original vector but collapsing start end records + (vector-ref x 0) ;; id 0 (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) + (if (number? s)(seconds->time-string s) s)) ;; starttime 1 (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5) ;; time delta - (vector-ref x 6))) + (if (number? s)(seconds->time-string s) s)) ;; endtime 2 + (vector-ref x 3) ;; status 3 + (vector-ref x 4) ;; duration 4 + (vector-ref x 5) ;; logfile 5 + (vector-ref x 6) ;; comment 6 + (vector-ref x 7))) ;; id 7 (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) + (time-b (vector-ref b 1)) + (id-a (vector-ref a 7)) + (id-b (vector-ref b 7))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) - (string