Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -43,11 +43,11 @@ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \ pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \ subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \ ezstepsmod.scm mtbody.scm envmod.scm genexample.scm mutils.scm \ - diff-report.scm tdb.scm vg.scm dcommon.scm + diff-report.scm tdb.scm vg.scm dcommon.scm dashboard-tests.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template @@ -92,11 +92,11 @@ # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm -GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ +GUISRCF = dashboard-context-menu.scm \ dashboard-guimonitor.scm gutils.scm tree.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -39,20 +39,23 @@ (declare (uses ezsteps)) (declare (uses subrun)) (declare (uses runsmod)) (declare (uses subrunmod)) -(use format fmt) -(require-library iup) -(import (prefix iup iup:)) - -(use canvas-draw) - -(use srfi-1 posix regex regex-case srfi-69) -(use (prefix sqlite3 sqlite3:)) - -(import commonmod +(module dashboard-tests + * + +(import scheme + chicken + format fmt + iup + (prefix iup iup:) + canvas-draw + srfi-1 posix regex regex-case srfi-69 + (prefix sqlite3 sqlite3:) + + commonmod configfmod rmtmod debugprint megatestmod dbmod @@ -65,916 +68,6 @@ ;; (include "common_records.scm") ;; (include "db_records.scm") (include "run_records.scm") -;;====================================================================== -;; C O M M O N -;;====================================================================== - -(define *dashboard-comment-share-slot* #f) - -(define (message-window msg) - (iup:show - (iup:dialog - (iup:vbox - (iup:label msg #:margin "40x40"))))) - -(define (dtests:get-pre-command #!key (default-override #f)) - (let* ((orig-pre-command "export CMD='") - (viewscreen-pre-command "viewscreen ") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) - - -(define (dtests:get-post-command #!key (default-override #f)) - (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" - "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) - (viewscreen-post-command "") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - - -(define (test-info-panel testdat store-label widgets) - (iup:frame - #:title "Test Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Testname: " - "Item path: " - "Current state: " - "Current status: " - "Test comment: " - "Test id: " - "Test date: ")) - (list (iup:label "" #:expand "VERTICAL")))) - (apply iup:vbox ; #:expand "YES" - (list - (store-label "testname" - (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-testname testdat))) - (store-label "item-path" - (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-item-path testdat))) - (store-label "teststate" - (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") - (lambda (testdat) - (db:test-get-state testdat))) - (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) - (hash-table-set! widgets "teststatus" - (lambda (testdat) - (let ((newstatus (db:test-get-status testdat)) - (oldstatus (iup:attribute lbl "TITLE"))) - (if (not (equal? oldstatus newstatus)) - (begin - (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) - (db:test-get-status testdat)))) - (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) - lbl) - (store-label "testcomment" - (iup:label "TestComment " - #:expand "HORIZONTAL") - (lambda (testdat) - (let ((newcomment (db:test-get-comment testdat))) - (if *dashboard-comment-share-slot* - (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") - newcomment)) - (iup:attribute-set! *dashboard-comment-share-slot* - "VALUE" - newcomment))) - newcomment))) - (store-label "testid" - (iup:label "TestId " - #:expand "HORIZONTAL") - (lambda (testdat) - (db:test-get-id testdat))) - (store-label "testdate" - (iup:label "TestDate " - #:expand "HORIZONTAL") - (lambda (testdat) - (seconds->work-week/day-time (db:test-get-event_time testdat)))) - ))))) - -;;====================================================================== -;; Test meta panel -;;====================================================================== - -(define (test-meta-panel-get-description testmeta) - (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) - -(define (test-meta-panel testmeta store-meta) - (iup:frame - #:title "Test Meta Data" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Author: " - "Owner: " - "Reviewed: " - "Tags: " - "Description: ")) - (list (iup:label "" #:expand "VERTICAL")))) - (apply iup:vbox ; #:expand "YES" - (list - (store-meta "author" - (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-author testmeta))) - (store-meta "owner" - (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-owner testmeta))) - (store-meta "reviewed" - (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) - (store-meta "tags" - (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-tags testmeta))) - (store-meta "description" - (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") - (lambda (testmeta) - (test-meta-panel-get-description testmeta))) - ))))) - - -;;====================================================================== -;; Run info panel -;;====================================================================== -(define (run-info-panel db keydat testdat runname) - (let* ((run-id (db:test-get-run_id testdat)) - (rundat (rmt:get-run-info run-id)) - (header (db:get-header rundat)) - (event_time (db:get-value-by-header (db:get-rows rundat) - (db:get-header rundat) - "event_time"))) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " "))) - keydat) - (list (iup:label "runname ") - (iup:label "run-id") - (iup:label "run-date")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc run-id)) - (iup:label (seconds->year-work-week/day-time event_time)) - (iup:label "" #:expand "VERTICAL")))))))) - -;;====================================================================== -;; Host info panel -;;====================================================================== -(define (host-info-panel testdat store-label) - (iup:frame - #:title "Remote host and Test Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" ;; The heading labels - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Hostname: " - "Disk free: " - "CPU Load: " - "Run duration: " - "Logfile: " - "Top process id: " - "Uname -a: ")) - (iup:label "" #:expand "VERTICAL"))) - (apply iup:vbox ; #:expand "YES" - (list - ;; NOTE: Yes, the host can change! - (store-label "HostName" - (iup:label ;; (sdb:qry 'getstr - (db:test-get-host testdat) ;; ) - #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-host testdat))) - (store-label "DiskFree" - (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-diskfree testdat)))) - (store-label "CPULoad" - (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-cpuload testdat)))) - (store-label "RunDuration" - (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") - (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) - (store-label "LogFile" - (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-final_logf testdat)))) - (store-label "ProcessId" - (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-process_id testdat)))) - (store-label "Uname" - (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") - (lambda (testdat) ;; (sdb:qry 'getstr - (db:test-get-uname testdat))) ;; ) - ))))) - -;; if there is a submegatest create a button to launch dashboard in that area -;; -(define (submegatest-panel dbstruct keydat testdat runname testconfig) - (let* ((test-run-dir (db:test-get-rundir testdat)) - (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea silent: #t)))) - (if subarea - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:button - "Launch Dashboard" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir)))) - (iup:vbox)))) - -;; use a global for setting the buttons colors -;; state status teststeps -(define *state-status* (vector #f #f #f)) -(define (update-state-status-buttons testdat) - (let* ((state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (color (car (gutils:get-color-for-state-status state status)))) - ((vector-ref *state-status* 0) state color) - ((vector-ref *state-status* 1) status color))) - -(define *dashboard-test-db* #t) -(define *dashboard-comment-share-slot* #f) - -;;====================================================================== -;; Set fields -;;====================================================================== -(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) - (let ((newcomment #f) - (newstatus #f) - (newstate #f) - (wtxtbox #f)) - (iup:frame - #:title "Set fields" - (iup:vbox - (iup:hbox (iup:label "Comment:") - (let ((txtbox (iup:textbox #:action (lambda (val a b) - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (rmt:test-set-state-status run-id test-id #f #f b) - ;; IDEA: Just set a variable with the proc to call? - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL"))) - (set! wtxtbox txtbox) - txtbox)) - - (apply iup:hbox - (iup:label "STATE:" #:size "30x") - (let* ((btns (map (lambda (state) - (let ((btn (iup:button state - #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" - #:action (lambda (x) - ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected - (db:test-set-state! testdat state))))) - btn)) - (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) - (vector-set! *state-status* 0 - (lambda (state color) - (for-each - (lambda (btn) - (let* ((name (iup:attribute btn "TITLE")) - (newcolor (if (equal? name state) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) - btns))) - btns)) - (apply iup:hbox - (iup:label "STATUS:" #:size "30x") - (let* ((btns (map (lambda (status) - (let ((btn (iup:button status - #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" - #:action (lambda (x) - (let ((t (iup:attribute x "TITLE"))) - (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver run-id testdat - (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) - (lambda (c) - (set! newcomment c) - (if wtxtbox - (begin - (iup:attribute-set! wtxtbox "VALUE" c) - (if (not *dashboard-comment-share-slot*) - (set! *dashboard-comment-share-slot* wtxtbox))) - )))) - (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected - (db:test-set-status! testdat status)))))))) - btn)) - (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) - (vector-set! *state-status* 1 - (lambda (status color) - (for-each - (lambda (btn) - (let* ((name (iup:attribute btn "TITLE")) - (newcolor (if (equal? name status) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) - btns))) - btns)))))) - -(define (dashboard-tests:run-a-step info) - #t) - -;; (define (dashboard-tests:step-run-control testdat stepname testconfig) -;; (let* ((mutex (make-mutex))) -;; (letrec ((dlg -;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" -;; #:title stepname -;; (iup:vbox ; #:expand "YES" -;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) -;; (iup:button "Re-run" -;; #:expand "HORIZONTAL" -;; #:action (lambda (obj) -;; (debug:catch-and-dump (lambda () -;; (thread-start! -;; (make-thread -;; (lambda () -;; (print "BB> started ezsteps:run-from") -;; (debug:catch-and-dump -;; (lambda () -;; (ezsteps:run-from testdat stepname #t)) -;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") -;; (print "BB> done ezsteps:run-from") -;; 'foo) -;; (conc "ezstep run single step " stepname))) -;; ) -;; "step-run-control action"))) -;; (iup:button "Re-run and continue" -;; #:expand "HORIZONTAL" -;; #:action (lambda (obj) -;; (debug:catch-and-dump -;; (lambda () -;; (thread-start! -;; (make-thread (lambda () -;; (ezsteps:run-from testdat stepname #f)) -;; (conc "ezstep run from step " stepname)))) -;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) -;; (iup:button "Close" -;; #:action (lambda (obj) -;; (iup:destroy! dlg))) -;; ;; (iup:button "Refresh test data" -;; ;; #:expand "HORIZONTAL" -;; ;; #:action (lambda (obj) -;; ;; (print "Refresh test data " stepname)) -;; )))) -;; dlg))) - -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) - (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) - (wregx (if (string? wpatt)(regexp wpatt) #f)) - (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) - (comnt (iup:textbox #:action (lambda (val a b) - (if wpatt - (if (string-match wregx b) - (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) - (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) - ))) - #:value (if ovrdval ovrdval (db:test-get-comment testdat)) - #:expand "HORIZONTAL")) - (dlog #f)) - (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title "SET WAIVER" - (iup:vbox ; #:expand "YES" - (iup:label (conc "Enter justification for waiving test " - (db:test-get-testname testdat) - (if (equal? (db:test-get-item-path testdat) "") - "" - (conc "/" (db:test-get-item-path testdat))))) - wmesg ;; the informational msg on whether it matches - comnt - (iup:hbox - (iup:button "Apply and Close " - #:expand "HORIZONTAL" - #:action (lambda (obj) - (let ((comment (iup:attribute comnt "VALUE")) - (test-id (db:test-get-id testdat))) - (if (or (not wpatt) - (string-match wregx comment)) - (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) - (db:test-set-status! testdat "WAIVED") - (cmtcmd comment) - (iup:destroy! dlog)))))) - (iup:button "Cancel" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (iup:destroy! dlog))))))) - dlog)) - - -;;====================================================================== -;; -;;====================================================================== -(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct #f) ;; NOT USED - (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) - (db-mod-time 0) ;; (file-modification-time db-path)) - (last-update 0) ;; (current-seconds)) - (request-update #t)) - (if (not testdat) - (begin - (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) - (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) - (test-registry (tests:get-all)) - (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) - (rundat (if testdat (rmt:get-run-info run-id) #f)) - (runname (if testdat (db:get-value-by-header (db:get-rows rundat) - (db:get-header rundat) - "runname") #f)) - ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) - ;; These next two are intentional bad values to ensure errors if they should not - ;; get filled in properly. - (logfile "/this/dir/better/not/exist") - (rundir (if testdat - (db:test-get-rundir testdat) - logfile)) - ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (augment-teststeps (lambda (inlov) - (map - (lambda (invec) - (list->vector - `( - ,@(reverse (cdr (reverse (vector->list invec)))) - "rerun this step" "restart from here" ))) - inlov))) - (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) - (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) - (testname (if testdat (db:test-get-testname testdat) "n/a")) - ;; (tests:get-testconfig testdat testname 'return-procs)) - (testmeta (if testdat - (let ((tm (rmt:testmeta-get-record testname))) - (if tm tm (make-db:testmeta))) - (make-db:testmeta))) - - (keystring (string-intersperse - (map (lambda (keyval) - ;; (conc ":" (car keyval) " " (cadr keyval))) - (cadr keyval)) - keydat) - "/")) - (item-path (db:test-get-item-path testdat)) - ;; this next block was added to fix a bug where variables were - ;; needed. Revisit this. - (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read - (if (common:file-exists? runconfigf) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) - #f) ;; do nothing, just keep on trucking .... - (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) - (make-hash-table)))) - (testconfig (begin - ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) - (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process - (handle-exceptions - exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! - (begin - (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) - (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) - (viewlog (lambda (x) - (if (common:file-exists? logfile) - ;(system (conc "firefox " 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 (common:file-exists? lfilename) - ;(system (conc "firefox " logfile "&")) - (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")) - ""))) - (common:without-vars - (conc "cd " rundir - ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") - "MT_.*")) - (message-window (conc "Directory " rundir " not found"))))) - (widgets (make-hash-table)) - (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) - ;; (max ..... (if (common:file-exists? testdat-path) - ;; (file-modification-time testdat-path) - ;; (begin - ;; (set! testdat-path (conc rundir "/testdat.db")) - ;; 0)))) - (need-update (or (and (>= curr-mod-time db-mod-time) - (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched - (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds - request-update)) - (newtestdat (if need-update - ;; NOTE: BUG HIDER, try to eliminate this exception handler - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id - ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - #f) - (rmt:get-test-info-by-id run-id test-id))))) - ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) - (cond - ((and need-update newtestdat) - (set! testdat newtestdat) - (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) - (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (set! rundir ;; (filedb:get-path *fdb* - (db:test-get-rundir testdat)) ;; ) - (set! testfullname (db:test-get-fullname testdat)) - ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) - - ;; I don't see why this was implemented this way. Please comment it ... - ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same - ;; (set! db-mod-time (+ curr-mod-time 1)) - ;; (set! db-mod-time curr-mod-time)) - - (if (not (eq? curr-mod-time db-mod-time)) - (set! db-mod-time curr-mod-time)) - (set! last-update (current-milliseconds)) - (set! request-update #f) ;; met the need ... - ) - (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) - (if need-update - (begin - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat))) - ;; (iup:refresh self) - ))) - (meta-widgets (make-hash-table)) - (self #f) - (store-label (lambda (name lbl cmd) - (hash-table-set! widgets name - (lambda (testdat) - (let ((newval (cmd testdat)) - (oldval (iup:attribute lbl "TITLE"))) - (if (not (equal? newval oldval)) - (begin - ;(mutex-lock! mx1) - (iup:attribute-set! lbl "TITLE" newval) - ;(mutex-unlock! mx1) - ))))) - lbl)) - (store-meta (lambda (name lbl cmd) - (hash-table-set! meta-widgets name - (lambda (testmeta) - (let ((newval (cmd testmeta)) - (oldval (iup:attribute lbl "TITLE"))) - (if (not (equal? newval oldval)) - (begin - ;(mutex-lock! mx1) - (iup:attribute-set! lbl "TITLE" newval) - ;(mutex-unlock! mx1) - ))))) - lbl)) - (store-button store-label) - (command-proc (lambda (command-text-box) - (let* ((cmd (iup:attribute command-text-box "VALUE"))) - (common:run-a-command cmd with-orig-env: #t)))) - (command-text-box (iup:textbox - #:expand "HORIZONTAL" - #:font "Courier New, -10" - #:action (lambda (obj cnum val) - ;; (print "cnum=" cnum) - (if (eq? cnum 13) - (command-proc obj))) - )) - (command-launch-button (iup:button "Execute!" #:action (lambda (x) - (command-proc command-text-box)))) - ;; (lambda (x) - ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) - ;; (fullcmd (conc (dtests:get-pre-command) - ;; cmd - ;; (dtests:get-post-command)))) - ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - ;; (common:without-vars fullcmd "MT_.*"))))) - (kill-jobs (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -set-state-status KILLREQ,n/a -testpatt %/% " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (run-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -run -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -clean-cache" - )))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -remove-runs -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v")))) - (clean-run-execute (lambda (x) - (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname - "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ";megatest -target " keystring " -runname " runname - " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -clean-cache" - ))) - (thread-start! (make-thread (lambda () - (common:run-a-command cmd)) - "clean-run-execute"))))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -remove-runs -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v")))) - (archive-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ))))) - (cond - ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) - ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) - (else - ;; (test-set-status! db run-id test-name state status itemdat) - (set! self ; - (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title testfullname - (iup:vbox ; #:expand "YES" - ;; The run and test info - (iup:hbox ; #:expand "YES" - (run-info-panel dbstruct keydat testdat runname) - (test-info-panel testdat store-label widgets) - (test-meta-panel testmeta store-meta)) - (iup:hbox - (host-info-panel testdat store-label) - (submegatest-panel dbstruct keydat testdat runname testconfig)) - ;; The controls - (iup:frame #:title "Actions" - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x") - (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") - (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") - (iup:button "Archive Test" #:action archive-test #:size "80x") - (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) - (apply - iup:hbox - (list command-text-box command-launch-button)))) - (set-fields-panel dbstruct run-id test-id testdat) - (let ((tabs - (iup:tabs - ;; Replace here with matrix - (let ((steps-matrix (iup:matrix - #:font "Courier New, -8" - #:expand "YES" - #:scrollbar "YES" - #:numcol 9 - #:numlin 100 - #:numcol-visible 9 - #:numlin-visible 5 - #:click-cb (lambda (obj lin col status) - ;; (if (equal? col 6) - (let* ((mtrx-rc (conc lin ":" 6)) - (fname (iup:attribute obj mtrx-rc)) - (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) - (case col - - ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) - ((8) (ezsteps:spawn-run-from testdat stepname #t)) - ((9) (ezsteps:spawn-run-from testdat stepname #f)) - (else (view-a-log fname)))))))) - ;; (let loop ((count 0)) - ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) - ;; (if (< count 30) - ;; (loop (+ count 1)))) - (iup:attribute-set! steps-matrix "0:1" "Step Name") - (iup:attribute-set! steps-matrix "0:2" "Start") - (iup:attribute-set! steps-matrix "0:3" "End") - (iup:attribute-set! steps-matrix "WIDTH3" "50") - (iup:attribute-set! steps-matrix "0:4" "Status") - (iup:attribute-set! steps-matrix "WIDTH4" "50") - (iup:attribute-set! steps-matrix "0:5" "Duration") - (iup:attribute-set! steps-matrix "0:6" "Log File") - (iup:attribute-set! steps-matrix "0:7" "Comment") - (iup:attribute-set! steps-matrix "0:8" "rerun only") - (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") - (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") - (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") - (iup:attribute-set! steps-matrix "0:9" "rerun & continue") - (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") - ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") - (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") - (let ((proc - (lambda (testdat) - (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) - (hash-table-set! widgets "StepsMatrix" proc) - (proc testdat)) - steps-matrix) - ;; populate the Test Data panel - (iup:frame - #:title "Test Data" - (let ((test-data - (iup:textbox ;; #:action (lambda (obj char val) - ;; #f) - #:expand "YES" - #:multiline "YES" - #:font "Courier New, -10" - #:size "100x100"))) - (hash-table-set! widgets "Test Data" - (lambda (testdat) ;; - (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) - (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment - (newval (string-intersperse - (append - (list - (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") - (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) - (map (lambda (x) - (format #f fmtstr - (db:test-data-get-category x) - (db:test-data-get-variable x) - (db:test-data-get-value x) - (db:test-data-get-expected x) - (db:test-data-get-tol x) - (db:test-data-get-status x) - (db:test-data-get-units x) - (db:test-data-get-type x) - (db:test-data-get-comment x))) - (rmt:read-test-data run-id test-id "%"))) - "\n"))) - (if (not (equal? currval newval)) - (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) - test-data)) - ;;(dashboard:run-controls) - ))) - (iup:attribute-set! tabs "TABTITLE0" "Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs)))) - (iup:show self) - (iup:callback-set! *tim* "ACTION_CB" - (lambda (x) - ;; Now start keeping the gui updated from the db - (refreshdat) ;; update from the db here - ;(thread-suspend! other-thread) - (if *exit-started* - (set! *exit-started* 'ok)))))))))) - -(define (colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -;; Display the tests as rows of boxes on the test/task pane -;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) - (canvas-clear! cnv) - (canvas-font-set! cnv "Helvetica, -10") - (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 1) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - )) - -(define (dboard:tabdat-test-patts-use vec) - (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? - -;; additional setters for dboard:data -(define (dboard:tabdat-test-patts-set!-use vec val) - (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) - -;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed -;; -(define (dashboard:update-run-command tabdat) - (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) - (cmd (dboard:tabdat-command tabdat)) - (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) - (if (or (not tp) - (equal? tp "")) - "%" - tp))) - (states (dboard:tabdat-states tabdat)) - (statuses (dboard:tabdat-statuses tabdat)) - (target (let ((targ-list (dboard:tabdat-target tabdat))) - (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) - (run-name (dboard:tabdat-run-name tabdat)) - (states-str (if (or (not states) - (null? states)) - "" - (conc " -state " (string-intersperse states ",")))) - (statuses-str (if (or (not statuses) - (null? statuses)) - "" - (conc " -status " (string-intersperse statuses ",")))) - (full-cmd "megatest")) - (case (string->symbol cmd) - ((run) - (set! full-cmd (conc full-cmd - " -run" - " -testpatt " - test-patt - " -target " - target - " -runname " - run-name - " -clean-cache" - ))) - ((remove-runs) - (set! full-cmd (conc full-cmd - " -remove-runs -runname " - run-name - " -target " - target - " -testpatt " - test-patt - states-str - statuses-str - ))) - (else (set! full-cmd " no valid command "))) - (iup:attribute-set! cmd-tb "VALUE" full-cmd))) - -(define (iuplistbox-fill-list lb items #!key (selected-item #f)) - (let ((i 1)) - (for-each (lambda (item) - (iup:attribute-set! lb (number->string i) item) - (if selected-item - (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) - (set! i (+ i 1))) - items) - ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) - i)) - -;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num -;; adds the updater passed in the updaters list at that hashkey -;; -(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) - (let* ((tnum (or tab-num - (dboard:commondat-curr-tab-num commondat))) - (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) - (hash-table-set! (dboard:commondat-updaters commondat) - tnum - (cons updater curr-updaters)))) - -(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) - (let* ((pre-cmd (dtests:get-pre-command)) - (post-cmd (dtests:get-post-command)) - (fullcmd (if (or pre-cmd post-cmd) - (conc pre-cmd cmd post-cmd) - (conc "viewscreen " cmd)))) - (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (cond - (with-vars (common:without-vars fullcmd)) - (with-orig-env (common:with-orig-env fullcmd)) - (else (common:without-vars fullcmd "MT_.*"))))) - +) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -496,11 +496,11 @@ (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";"))) (if (and init-proc (or force-init (not db-exists))) (init-proc db)) db)) - expire-time: 5) + expire-time: 15) (begin (if (file-exists? fname ) (let ((db (sqlite3:open-database fname))) ;; pragmas synchronous not needed because this db is used read-only ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -25,10 +25,11 @@ (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) (declare (uses testsmod)) (declare (uses mtargs)) +(declare (uses vg)) (module dcommon * (import scheme @@ -39,25 +40,27 @@ extras srfi-1 srfi-4 srfi-18 srfi-69 - commonmod - configfmod - rmtmod - testsmod - dbmod - debugprint) - -(import format + format (prefix iup iup:) canvas-draw canvas-draw-iup regex data-structures typed-records matchable + (prefix sqlite3 sqlite3:) + + commonmod + configfmod + rmtmod + testsmod + dbmod + debugprint + vg (prefix mtargs args:) ) (include "megatest-version.scm") (include "common_records.scm") @@ -5256,10 +5259,1004 @@ ;; The heavy lifting starts here ;;====================================================================== (stop-the-train) +(define (dcommon-main) +(define last-copy-time 0) + + +;; Sync to tmp only if in read-only mode. + +(define (sync-db-to-tmp tabdat) + (let* ((db-file "./.mtdb/main.db")) + (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) + (begin + (db:multi-db-sync (db:setup) 'old2new) + (set! last-copy-time (current-seconds)) + ) + ) + ) +) + +;; ########################### top level code ######################## +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (for-each (lambda (var) + ;; (display " ")(display var) + (if (get-environment-variable var) + (begin + (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (exit 1)))) + '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) + ) +) + +;; This is NOT good +;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) +;; This should be OK but it really should not be necessary +(setenv "MT_RUN_AREA_HOME" (current-directory)) + +(if (not (null? remargs)) + (if remargs + (begin + (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + + + + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (common:file-exists? debugcontrolf) + (load debugcontrolf))) +) + +;;====================================================================== +;; C O M M O N +;;====================================================================== + +(define *dashboard-comment-share-slot* #f) + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (dtests:get-pre-command #!key (default-override #f)) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + + +(define (test-info-panel testdat store-label widgets) + (iup:frame + #:title "Test Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Testname: " + "Item path: " + "Current state: " + "Current status: " + "Test comment: " + "Test id: " + "Test date: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-label "testname" + (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-testname testdat))) + (store-label "item-path" + (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-item-path testdat))) + (store-label "teststate" + (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-state testdat))) + (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) + (hash-table-set! widgets "teststatus" + (lambda (testdat) + (let ((newstatus (db:test-get-status testdat)) + (oldstatus (iup:attribute lbl "TITLE"))) + (if (not (equal? oldstatus newstatus)) + (begin + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) + (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) + lbl) + (store-label "testcomment" + (iup:label "TestComment " + #:expand "HORIZONTAL") + (lambda (testdat) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-share-slot* + "VALUE" + newcomment))) + newcomment))) + (store-label "testid" + (iup:label "TestId " + #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) + ))))) + +;;====================================================================== +;; Test meta panel +;;====================================================================== + +(define (test-meta-panel-get-description testmeta) + (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) + +(define (test-meta-panel testmeta store-meta) + (iup:frame + #:title "Test Meta Data" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Author: " + "Owner: " + "Reviewed: " + "Tags: " + "Description: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-meta "author" + (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-author testmeta))) + (store-meta "owner" + (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-owner testmeta))) + (store-meta "reviewed" + (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) + (store-meta "tags" + (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-tags testmeta))) + (store-meta "description" + (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") + (lambda (testmeta) + (test-meta-panel-get-description testmeta))) + ))))) + + +;;====================================================================== +;; Run info panel +;;====================================================================== +(define (run-info-panel db keydat testdat runname) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (rmt:get-run-info run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) + +;;====================================================================== +;; Host info panel +;;====================================================================== +(define (host-info-panel testdat store-label) + (iup:frame + #:title "Remote host and Test Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" ;; The heading labels + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Hostname: " + "Disk free: " + "CPU Load: " + "Run duration: " + "Logfile: " + "Top process id: " + "Uname -a: ")) + (iup:label "" #:expand "VERTICAL"))) + (apply iup:vbox ; #:expand "YES" + (list + ;; NOTE: Yes, the host can change! + (store-label "HostName" + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-host testdat))) + (store-label "DiskFree" + (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-diskfree testdat)))) + (store-label "CPULoad" + (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-cpuload testdat)))) + (store-label "RunDuration" + (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") + (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) + (store-label "LogFile" + (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-final_logf testdat)))) + (store-label "ProcessId" + (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-process_id testdat)))) + (store-label "Uname" + (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) + ))))) + +;; if there is a submegatest create a button to launch dashboard in that area +;; +(define (submegatest-panel dbstruct keydat testdat runname testconfig) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (subarea (subrun:get-runarea test-run-dir)) + (area-exists (and subarea (common:file-exists? subarea silent: #t)))) + (if subarea + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir)))) + (iup:vbox)))) + +;; use a global for setting the buttons colors +;; state status teststeps +(define *state-status* (vector #f #f #f)) +(define (update-state-status-buttons testdat) + (let* ((state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (color (car (gutils:get-color-for-state-status state status)))) + ((vector-ref *state-status* 0) state color) + ((vector-ref *state-status* 1) status color))) + +(define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) + +;;====================================================================== +;; Set fields +;;====================================================================== +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) + (let ((newcomment #f) + (newstatus #f) + (newstate #f) + (wtxtbox #f)) + (iup:frame + #:title "Set fields" + (iup:vbox + (iup:hbox (iup:label "Comment:") + (let ((txtbox (iup:textbox #:action (lambda (val a b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (rmt:test-set-state-status run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + + (apply iup:hbox + (iup:label "STATE:" #:size "30x") + (let* ((btns (map (lambda (state) + (let ((btn (iup:button state + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected + (db:test-set-state! testdat state))))) + btn)) + (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) + (vector-set! *state-status* 0 + (lambda (state color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name state) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)) + (apply iup:hbox + (iup:label "STATUS:" #:size "30x") + (let* ((btns (map (lambda (status) + (let ((btn (iup:button status + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver run-id testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected + (db:test-set-status! testdat status)))))))) + btn)) + (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + (vector-set! *state-status* 1 + (lambda (status color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name status) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)))))) + +(define (dashboard-tests:run-a-step info) + #t) + +;; (define (dashboard-tests:step-run-control testdat stepname testconfig) +;; (let* ((mutex (make-mutex))) +;; (letrec ((dlg +;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" +;; #:title stepname +;; (iup:vbox ; #:expand "YES" +;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) +;; (iup:button "Re-run" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump (lambda () +;; (thread-start! +;; (make-thread +;; (lambda () +;; (print "BB> started ezsteps:run-from") +;; (debug:catch-and-dump +;; (lambda () +;; (ezsteps:run-from testdat stepname #t)) +;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") +;; (print "BB> done ezsteps:run-from") +;; 'foo) +;; (conc "ezstep run single step " stepname))) +;; ) +;; "step-run-control action"))) +;; (iup:button "Re-run and continue" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump +;; (lambda () +;; (thread-start! +;; (make-thread (lambda () +;; (ezsteps:run-from testdat stepname #f)) +;; (conc "ezstep run from step " stepname)))) +;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) +;; (iup:button "Close" +;; #:action (lambda (obj) +;; (iup:destroy! dlg))) +;; ;; (iup:button "Refresh test data" +;; ;; #:expand "HORIZONTAL" +;; ;; #:action (lambda (obj) +;; ;; (print "Refresh test data " stepname)) +;; )))) +;; dlg))) + +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) + (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) + (wregx (if (string? wpatt)(regexp wpatt) #f)) + (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) + (comnt (iup:textbox #:action (lambda (val a b) + (if wpatt + (if (string-match wregx b) + (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) + (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) + ))) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:expand "HORIZONTAL")) + (dlog #f)) + (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title "SET WAIVER" + (iup:vbox ; #:expand "YES" + (iup:label (conc "Enter justification for waiving test " + (db:test-get-testname testdat) + (if (equal? (db:test-get-item-path testdat) "") + "" + (conc "/" (db:test-get-item-path testdat))))) + wmesg ;; the informational msg on whether it matches + comnt + (iup:hbox + (iup:button "Apply and Close " + #:expand "HORIZONTAL" + #:action (lambda (obj) + (let ((comment (iup:attribute comnt "VALUE")) + (test-id (db:test-get-id testdat))) + (if (or (not wpatt) + (string-match wregx comment)) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) + (db:test-set-status! testdat "WAIVED") + (cmtcmd comment) + (iup:destroy! dlog)))))) + (iup:button "Cancel" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (iup:destroy! dlog))))))) + dlog)) + + +;;====================================================================== +;; +;;====================================================================== +(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) + (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT USED + (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) + (db-mod-time 0) ;; (file-modification-time db-path)) + (last-update 0) ;; (current-seconds)) + (request-update #t)) + (if (not testdat) + (begin + (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) + (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (test-registry (tests:get-all)) + (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) + (rundat (if testdat (rmt:get-run-info run-id) #f)) + (runname (if testdat (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "runname") #f)) + ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + ;; These next two are intentional bad values to ensure errors if they should not + ;; get filled in properly. + (logfile "/this/dir/better/not/exist") + (rundir (if testdat + (db:test-get-rundir testdat) + logfile)) + ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found + (augment-teststeps (lambda (inlov) + (map + (lambda (invec) + (list->vector + `( + ,@(reverse (cdr (reverse (vector->list invec)))) + "rerun this step" "restart from here" ))) + inlov))) + (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (testname (if testdat (db:test-get-testname testdat) "n/a")) + ;; (tests:get-testconfig testdat testname 'return-procs)) + (testmeta (if testdat + (let ((tm (rmt:testmeta-get-record testname))) + (if tm tm (make-db:testmeta))) + (make-db:testmeta))) + + (keystring (string-intersperse + (map (lambda (keyval) + ;; (conc ":" (car keyval) " " (cadr keyval))) + (cadr keyval)) + keydat) + "/")) + (item-path (db:test-get-item-path testdat)) + ;; this next block was added to fix a bug where variables were + ;; needed. Revisit this. + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read + (if (common:file-exists? runconfigf) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) + #f) ;; do nothing, just keep on trucking .... + (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) + (make-hash-table)))) + (testconfig (begin + ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) + (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process + (handle-exceptions + exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! + (begin + (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) + (viewlog (lambda (x) + (if (common:file-exists? logfile) + ;(system (conc "firefox " 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 (common:file-exists? lfilename) + ;(system (conc "firefox " logfile "&")) + (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")) + ""))) + (common:without-vars + (conc "cd " rundir + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") + "MT_.*")) + (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) + (refreshdat (lambda () + (let* ((curr-mod-time (file-modification-time db-path)) + ;; (max ..... (if (common:file-exists? testdat-path) + ;; (file-modification-time testdat-path) + ;; (begin + ;; (set! testdat-path (conc rundir "/testdat.db")) + ;; 0)))) + (need-update (or (and (>= curr-mod-time db-mod-time) + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds + request-update)) + (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id + ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + #f) + (rmt:get-test-info-by-id run-id test-id))))) + ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) + (cond + ((and need-update newtestdat) + (set! testdat newtestdat) + (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) + (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) + (set! rundir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) + (set! testfullname (db:test-get-fullname testdat)) + ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) + (set! db-mod-time curr-mod-time)) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... + ) + (need-update ;; if this was true and yet there is no data .... + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) + (meta-widgets (make-hash-table)) + (self #f) + (store-label (lambda (name lbl cmd) + (hash-table-set! widgets name + (lambda (testdat) + (let ((newval (cmd testdat)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-meta (lambda (name lbl cmd) + (hash-table-set! meta-widgets name + (lambda (testmeta) + (let ((newval (cmd testmeta)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-button store-label) + (command-proc (lambda (command-text-box) + (let* ((cmd (iup:attribute command-text-box "VALUE"))) + (common:run-a-command cmd with-orig-env: #t)))) + (command-text-box (iup:textbox + #:expand "HORIZONTAL" + #:font "Courier New, -10" + #:action (lambda (obj cnum val) + ;; (print "cnum=" cnum) + (if (eq? cnum 13) + (command-proc obj))) + )) + (command-launch-button (iup:button "Execute!" #:action (lambda (x) + (command-proc command-text-box)))) + ;; (lambda (x) + ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) + ;; (fullcmd (conc (dtests:get-pre-command) + ;; cmd + ;; (dtests:get-post-command)))) + ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + ;; (common:without-vars fullcmd "MT_.*"))))) + (kill-jobs (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -set-state-status KILLREQ,n/a -testpatt %/% " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -run -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + )))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (clean-run-execute (lambda (x) + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";megatest -target " keystring " -runname " runname + " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + ))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (archive-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ))))) + (cond + ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + (else + ;; (test-set-status! db run-id test-name state status itemdat) + (set! self ; + (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title testfullname + (iup:vbox ; #:expand "YES" + ;; The run and test info + (iup:hbox ; #:expand "YES" + (run-info-panel dbstruct keydat testdat runname) + (test-info-panel testdat store-label widgets) + (test-meta-panel testmeta store-meta)) + (iup:hbox + (host-info-panel testdat store-label) + (submegatest-panel dbstruct keydat testdat runname testconfig)) + ;; The controls + (iup:frame #:title "Actions" + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") + (iup:button "Archive Test" #:action archive-test #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (apply + iup:hbox + (list command-text-box command-launch-button)))) + (set-fields-panel dbstruct run-id test-id testdat) + (let ((tabs + (iup:tabs + ;; Replace here with matrix + (let ((steps-matrix (iup:matrix + #:font "Courier New, -8" + #:expand "YES" + #:scrollbar "YES" + #:numcol 9 + #:numlin 100 + #:numcol-visible 9 + #:numlin-visible 5 + #:click-cb (lambda (obj lin col status) + ;; (if (equal? col 6) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc)) + (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) + (case col + + ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) + ((8) (ezsteps:spawn-run-from testdat stepname #t)) + ((9) (ezsteps:spawn-run-from testdat stepname #f)) + (else (view-a-log fname)))))))) + ;; (let loop ((count 0)) + ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) + ;; (if (< count 30) + ;; (loop (+ count 1)))) + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "50") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") + (iup:attribute-set! steps-matrix "0:8" "rerun only") + (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") + (iup:attribute-set! steps-matrix "0:9" "rerun & continue") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + (let ((proc + (lambda (testdat) + (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) + (hash-table-set! widgets "StepsMatrix" proc) + (proc testdat)) + steps-matrix) + ;; populate the Test Data panel + (iup:frame + #:title "Test Data" + (let ((test-data + (iup:textbox ;; #:action (lambda (obj char val) + ;; #f) + #:expand "YES" + #:multiline "YES" + #:font "Courier New, -10" + #:size "100x100"))) + (hash-table-set! widgets "Test Data" + (lambda (testdat) ;; + (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment + (newval (string-intersperse + (append + (list + (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") + (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) + (map (lambda (x) + (format #f fmtstr + (db:test-data-get-category x) + (db:test-data-get-variable x) + (db:test-data-get-value x) + (db:test-data-get-expected x) + (db:test-data-get-tol x) + (db:test-data-get-status x) + (db:test-data-get-units x) + (db:test-data-get-type x) + (db:test-data-get-comment x))) + (rmt:read-test-data run-id test-id "%"))) + "\n"))) + (if (not (equal? currval newval)) + (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) + test-data)) + ;;(dashboard:run-controls) + ))) + (iup:attribute-set! tabs "TABTITLE0" "Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs)))) + (iup:show self) + (iup:callback-set! *tim* "ACTION_CB" + (lambda (x) + ;; Now start keeping the gui updated from the db + (refreshdat) ;; update from the db here + ;(thread-suspend! other-thread) + (if *exit-started* + (set! *exit-started* 'ok)))))))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +(define (dboard:tabdat-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:tabdat-run-name tabdat)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " -state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " -status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) + +(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) + (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + (cond + (with-vars (common:without-vars fullcmd)) + (with-orig-env (common:with-orig-env fullcmd)) + (else (common:without-vars fullcmd "MT_.*"))))) + (define (main) ;; (print "Starting dashboard main") (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) (target (args:get-arg "-target")) @@ -5350,89 +6347,7 @@ ) ) ) ) -(define (dcommon-main) -(define last-copy-time 0) - - -;; Sync to tmp only if in read-only mode. - -(define (sync-db-to-tmp tabdat) - (let* ((db-file "./.mtdb/main.db")) - (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) - (begin - (db:multi-db-sync (db:setup) 'old2new) - (set! last-copy-time (current-seconds)) - ) - ) - ) -) - -;; ########################### top level code ######################## -;; check for MT_* environment variables and exit if found -(if (not (args:get-arg "-test")) - (begin - (for-each (lambda (var) - ;; (display " ")(display var) - (if (get-environment-variable var) - (begin - (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") - (exit 1)))) - '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - ) -) - -;; This is NOT good -;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) -;; This should be OK but it really should not be necessary -(setenv "MT_RUN_AREA_HOME" (current-directory)) - -(if (not (null? remargs)) - (if remargs - (begin - (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) - (exit) - ) - (begin - (print help) - (exit) - ) - ) -) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - - - - -(if (args:get-arg "-start-dir") - (if (directory-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - - -;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature -;; first check for the switch -;; -(if (or - (configf:lookup *configdat* "dashboard" "no-detachbox") - (not (file-exists? "/etc/os-release"))) - (set! iup:detachbox iup:vbox)) - - - -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (common:file-exists? debugcontrolf) - (load debugcontrolf))) -) ) ADDED utils/extract-export-list.scm Index: utils/extract-export-list.scm ================================================================== --- /dev/null +++ utils/extract-export-list.scm @@ -0,0 +1,34 @@ +;; #!/bin/bash + +(module extract + * + +(import scheme + chicken + + ) + +(define (get-norefs) + (with-input-from-pipe + "grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}'" + read-lines)) + +(define (get-parent-file noref) + (with-input-from-pipe + "grep $fn *mod.scm|grep define|cut -d: -f1" + read-lines)) + + +;; +;; LAST_PARENT=foobar +;; +;; for fn in $(grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}');do +;; PARENT=$(grep $fn *mod.scm|grep define|cut -d: -f1) +;; if [[ $PARENT != $LAST_PARENT ]];then +;; echo +;; echo $PARENT +;; LAST_PARENT=$PARENT +;; fi +;; echo $fn +;; done +;;