Index: api-inc.scm
==================================================================
--- api-inc.scm
+++ api-inc.scm
@@ -241,11 +241,11 @@
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
- ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
+ ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
@@ -265,11 +265,11 @@
((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
- ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
+ ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
Index: client-inc.scm
==================================================================
--- client-inc.scm
+++ client-inc.scm
@@ -31,12 +31,12 @@
#;(define (client:logout serverdat)
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
-(define (client:connect iface port)
- (http:client-connect iface port)
+#;(define (client:connect iface port)
+ (http-transport:client-connect iface port)
#;(case (server:get-transport)
((rpc) (rpc:client-connect iface port))
((http) (http:client-connect iface port))
((zmq) (zmq:client-connect iface port))
(else (rpc:client-connect iface port))))
Index: common-inc.scm
==================================================================
--- common-inc.scm
+++ common-inc.scm
@@ -1201,25 +1201,25 @@
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
- (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
- (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
- patts-from-mode-patt)
- (begin
- (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
- #f))) ;; We do NOT fall back to "%"
+ (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
+ (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
+ patts-from-mode-patt)
+ (begin
+ (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
+ #f))) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
;; tags-testpatt)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
(else
- (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
- args-testpatt))))
+ (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
+ args-testpatt))))
(define (common:false-on-exception thunk #!key (message #f))
(handle-exceptions exn
@@ -2882,11 +2882,11 @@
;; NMSG AND NEW API
;;======================================================================
;; nm based server experiment, keep around for now.
;;
-(define (nm:start-server dbconn #!key (given-host-name #f))
+#;(define (nm:start-server dbconn #!key (given-host-name #f))
(let* ((srvdat (start-raw-server given-host-name: given-host-name))
(host-name (srvdat-host srvdat))
(soc (srvdat-soc srvdat)))
;; start the queue processor (save for second round of development)
@@ -2913,12 +2913,10 @@
(queue-push cmddat) ;; put request into the queue
(nn-send soc "queued")) ;; reply with "queued"
(print "ERROR: ["(common:human-time)"] BAD request " dat))
(loop (nn-recv soc)))))
(nn-close soc)))
-
-
;;======================================================================
;; D A S H B O A R D U S E R V I E W S
;;======================================================================
Index: configf-inc.scm
==================================================================
--- configf-inc.scm
+++ configf-inc.scm
@@ -682,11 +682,11 @@
(begin
(if (null? sdat)(set! sdat (list (conc "[" section "]"))))
(set! sdat (append sdat (list (conc var " " val))))))))
svars)
(set! fdat (append fdat sdat))))
- (delete-duplicates (append require-sections (hash-table-keys indat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
;; step 5: Write out new file
(with-output-to-file fname
(lambda ()
(for-each
ADDED dashboard-tests-inc.scm
Index: dashboard-tests-inc.scm
==================================================================
--- /dev/null
+++ dashboard-tests-inc.scm
@@ -0,0 +1,805 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+;;======================================================================
+;; Test info panel
+;;======================================================================
+
+;;======================================================================
+;; C O M M O N
+;;======================================================================
+
+(define *dashboard-comment-share-slot* #f)
+
+(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 (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
+ (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree")
+ ;; local: #t))
+ (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
+ #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!
+ (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
+ (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))
+ (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-prox 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 (print "ERROR: bad test info for " test-id)(exit 1)))
+ ((not rundat)(begin (print "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) (print "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))))))))))
+
Index: db-inc.scm
==================================================================
--- db-inc.scm
+++ db-inc.scm
@@ -209,11 +209,11 @@
(readyfname (conc parent-dir "/.ready-" raw-fname))
(readyexists (common:file-exists? readyfname)))
(if (not readyexists)
(common:simple-file-lock-and-wait lockfname))
(let ((db (sqlite3:open-database fname)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
(begin
;;(print "DEBUG: Setting tmp_mode for " fname)
(sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
@@ -1501,11 +1501,11 @@
(define (open-logging-db)
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (common:file-exists? dbpath))
(db (sqlite3:open-database dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
+ (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(begin
@@ -1917,11 +1917,11 @@
(define (db:open-no-sync-db)
(let* ((dbpath (db:dbfile-path))
(dbname (conc dbpath "/no-sync.db"))
(db-exists (common:file-exists? dbname))
(db (sqlite3:open-database dbname)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(if (not db-exists)
(begin
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -62,10 +62,11 @@
data-structures
directory-utils
dot-locking
extras
files
+ fmt
format
hostinfo
http-client
intarweb
irregex
@@ -75,13 +76,15 @@
message-digest
pathname-expand
pkts
ports
posix
+ ;; queue
regex
regex-case
s11n
+ sparse-vectors
spiffy
spiffy-directory-listing
spiffy-request-vars
sql-de-lite
srfi-1
@@ -135,18 +138,20 @@
;;======================================================================
;; L O C K I N G M E C H A N I S M S
;;======================================================================
(include "megatest-fossil-hash.scm")
+(include "megatest-version.scm")
(include "api-inc.scm")
(include "archive-inc.scm")
(include "client-inc.scm")
(include "common-inc.scm")
(include "configf-inc.scm")
(include "db-inc.scm")
(include "dcommon-inc.scm")
+(include "dashboard-tests-inc.scm")
(include "env-inc.scm")
(include "ezsteps-inc.scm")
(include "http-transport-inc.scm")
(include "items-inc.scm")
(include "keys-inc.scm")
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -16,8 +16,8 @@
;; along with Megatest. If not, see .
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
-(declare (unit megatest-version))
+;; (declare (unit megatest-version))
(define megatest-version 1.6536)