Index: dashboard-tests-inc.scm
==================================================================
--- dashboard-tests-inc.scm
+++ dashboard-tests-inc.scm
@@ -23,10 +23,121 @@
;;======================================================================
;;======================================================================
;; C O M M O N
;;======================================================================
+
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns (string->number (or (args:get-arg "-cols")
+ (configf:lookup *configdat* "dashboard" "cols")
+ "8"))) : number) ;;
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+ ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
+ ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
+ ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list) ;; list of itemized tests
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+ ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
+ ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
+ ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
+ ((all-test-names '()) : list)
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Run times layout
+ ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
+ (graph-matrix #f)
+ ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
+ ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
+ ((graph-matrix-row 1) : number)
+ ((graph-matrix-col 1) : number)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
+ (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (access-mode (db:get-access-mode)) ;; use cached db or not
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+ ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+ ;; runs-summary tab state
+ ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
+ ((runs-summary-mode-buttons '()) : list)
+ ((runs-summary-mode 'one-run) : symbol)
+ ((runs-summary-mode-change-callbacks '()) : list)
+ (runs-summary-source-runname-label #f)
+ (runs-summary-dest-runname-label #f)
+ ;; runs summary view
+
+ tests-tree ;; used in newdashboard
+ )
(define *dashboard-comment-share-slot* #f)
(define (message-window msg)
(iup:show
@@ -611,11 +722,11 @@
#:expand "HORIZONTAL"
#:font "Courier New, -10"
#:action (lambda (obj cnum val)
;; (print "cnum=" cnum)
(if (eq? cnum 13)
- (command-prox obj)))
+ (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"))
@@ -807,5 +918,88 @@
(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)))
+
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -250,121 +250,10 @@
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
(cons updater curr-updaters))))
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat
- ;; runs
- ((allruns '()) : list) ;; list of dboard:rundat records
- ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
- ((done-runs '()) : list) ;; list of runs already drawn
- ((not-done-runs '()) : list) ;; list of runs not yet drawn
- (header #f) ;; header for decoding the run records
- (keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols")
- (configf:lookup *configdat* "dashboard" "cols")
- "8"))) : number) ;;
- ((tot-runs 0) : number)
- ((last-data-update 0) : number) ;; last time the data in allruns was updated
- ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
- (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
- ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
- ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
- ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
-
- ;; Runs view
- ((buttondat (make-hash-table)) : hash-table) ;;
- ((item-test-names '()) : list) ;; list of itemized tests
- ((run-keys (make-hash-table)) : hash-table)
- (runs-matrix #f) ;; used in newdashboard
- ((start-run-offset 0) : number) ;; left-right slider value
- ((start-test-offset 0) : number) ;; up-down slider value
- ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
- ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
- ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
- ((all-test-names '()) : list)
-
- ;; Canvas and drawing data
- (cnv #f)
- (cnv-obj #f)
- (drawing #f)
- ((run-start-row 0) : number)
- ((max-row 0) : number)
- ((running-layout #f) : boolean)
- (originx #f)
- (originy #f)
- ((layout-update-ok #t) : boolean)
- ((compact-layout #t) : boolean)
-
- ;; Run times layout
- ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
- (graph-matrix #f)
- ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
- ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
- ((graph-matrix-row 1) : number)
- ((graph-matrix-col 1) : number)
-
- ;; Controls used to launch runs etc.
- ((command "") : string) ;; for run control this is the command being built up
- (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
- (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
- (key-listboxes #f)
- (key-lbs #f)
- run-name ;; from run name setting widget
- states ;; states for -state s1,s2 ...
- statuses ;; statuses for -status s1,s2 ...
-
- ;; Selector variables
- curr-run-id ;; current row to display in Run summary view
- prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
- curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
- ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
- ((hide-empty-runs #f) : boolean)
- ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
- (hide-not-hide-button #f)
- ((searchpatts (make-hash-table)) : hash-table) ;;
- ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
- ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
- (target #f)
- (test-patts #f)
-
- ;; db info to file the .db files for the area
- (access-mode (db:get-access-mode)) ;; use cached db or not
- (dbdir #f)
- (dbfpath #f)
- (dbkeys #f)
- ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
- (monitor-db-path #f) ;; where to find monitor.db
- ro ;; is the database read-only?
-
- ;; tests data
- ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
-
- ;; runs tree
- ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
- (runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
- ;; tab data
- ((view-changed #t) : boolean)
- ((xadj 0) : number) ;; x slider number (if using canvas)
- ((yadj 0) : number) ;; y slider number (if using canvas)
- ;; runs-summary tab state
- ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
- ((runs-summary-mode-buttons '()) : list)
- ((runs-summary-mode 'one-run) : symbol)
- ((runs-summary-mode-change-callbacks '()) : list)
- (runs-summary-source-runname-label #f)
- (runs-summary-dest-runname-label #f)
- ;; runs summary view
-
- tests-tree ;; used in newdashboard
- )
-
;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
(cons dboard:tabdat?
(lambda (tabdat-item)
@@ -378,17 +267,10 @@
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
-(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)))
-
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
@@ -549,16 +431,10 @@
;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
i))
(define (pad-list l n)(append l (make-list (- n (length l)))))
-(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))))
-
(define (dboard:compare-tests test1 test2)
(let* ((test-name1 (db:test-get-testname test1))
(item-path1 (db:test-get-item-path test1))
(eventtime1 (db:test-get-event_time test1))
(test-name2 (db:test-get-testname test2))
@@ -1278,80 +1154,10 @@
(let ((all (hash-table-keys alltgls)))
(proc all)))
"text-list-toggle-box"))))
items))))
-;; 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)))
-
-;; 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))
- ))
-
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
Index: env-inc.scm
==================================================================
--- env-inc.scm
+++ env-inc.scm
@@ -67,12 +67,12 @@
(val (cadr row)))
(hash-table-set! result var
(if (and (hash-table-ref/default results var #f)
(assoc var paths)) ;; this var is a path and there is a previous path
(let ((sep (cadr (assoc var paths))))
- (env:merge-path-envvar sep (hash-table-ref results var) valb))
- valb)))))
+ (env:merge-path-envvar sep (hash-table-ref results var) val))
+ val)))))
(sql db "SELECT var,val FROM envvars WHERE context=?")
context))
contexts)
result))
ADDED gutils-inc.scm
Index: gutils-inc.scm
==================================================================
--- /dev/null
+++ gutils-inc.scm
@@ -0,0 +1,82 @@
+;;======================================================================
+;; 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 .
+;;
+;;======================================================================
+
+;; NOTE: These functions will move to iuputils
+
+(define (gutils: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))))
+
+(define gutils:colors
+ '((PASS . "70 249 73")
+ (FAIL . "253 33 49")
+ (SKIP . "230 230 0")))
+
+(define (gutils:get-color-spec effective-state)
+ (or (alist-ref effective-state gutils:colors)
+ (alist-ref 'FAIL gutils:colors)))
+
+;; BBnote - state status dashboard button color / text defined here
+(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
+ ;; ((if get-label cadr car)
+ (case (string->symbol state)
+ ((COMPLETED) ;; ARCHIVED)
+ (case (string->symbol status)
+ ((PASS) (list "70 249 73" status))
+ ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
+ ((WARN WAIVED) (list "255 172 13" status))
+ ((SKIP) (list (gutils:get-color-spec 'SKIP) status))
+ ((ABORT) (list "198 36 166" status))
+ (else (list "253 33 49" status))))
+ ((ARCHIVED)
+ (case (string->symbol status)
+ ((PASS) (list "70 170 73" status))
+ ((WARN WAIVED) (list "200 130 13" status))
+ ((SKIP) (list (gutils:get-color-spec 'SKIP) status))
+ (else (list "180 33 49" status))))
+ ;; (if (equal? status "PASS")
+ ;; '("70 249 73" "PASS")
+ ;; (if (or (equal? status "WARN")
+ ;; (equal? status "WAIVED"))
+ ;; (list "255 172 13" status)
+ ;; (list "223 33 49" status)))) ;; greenish orangeish redish
+ ((LAUNCHED) (list "101 123 142" state))
+ ((CHECK) (list "255 100 50" state))
+ ((REMOTEHOSTSTART) (list "50 130 195" state))
+ ((RUNNING STARTED) (list "9 131 232" state))
+ ((KILLREQ) (list "39 82 206" state))
+ ((KILLED) (list "234 101 17" state))
+ ((NOT_STARTED) (case (string->symbol status)
+ ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
+ (else (list "240 240 240" state))))
+ ;; for xor mode below
+ ;;
+ ((CLEAN)
+ (case (string->symbol status)
+ ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
+ (else (list "60 235 63" status))))
+ ((DIRTY-BETTER) (list "160 255 153" status))
+ ((DIRTY-WORSE) (list "165 42 42" status))
+ ((BOTH-BAD) (list "180 33 49" status))
+
+ (else (list "192 192 192" state))))
+
Index: http-transport-inc.scm
==================================================================
--- http-transport-inc.scm
+++ http-transport-inc.scm
@@ -283,11 +283,11 @@
(if (vector-ref res 0) ;; this is the first flag or the second flag?
res ;; this is the *inner* vector? seriously? why?
(if (debug:debug-mode 11)
(let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
(print-call-chain (current-error-port))
- (debug:print-error 11 *default-log-port* "error above occured at server, res=" res " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 11 *default-log-port* " server call chain:")
(pp (vector-ref res 1) (current-error-port))
(signal (vector-ref res 0)))
res))
(signal (make-composite-condition
@@ -356,17 +356,18 @@
(define (http-transport:keep-running)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
(debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
- (let* ((tmp-area (common:get-db-tmp-area))
+ (let* ((sdat #f)
+ (tmp-area (common:get-db-tmp-area))
(started-file (conc tmp-area "/.server-started"))
(server-start-time (current-seconds))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
(last-sdat "not this"))
- (let ((sdat #f))
+ (begin ;; let ((sdat #f))
(thread-sleep! 0.01)
(debug:print-info 0 *default-log-port* "Waiting for server alive signature")
(mutex-lock! *heartbeat-mutex*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
@@ -392,16 +393,16 @@
(T . server)
(pid . ,(current-process-id))
(ipaddr . ,(car sdat))
(port . ,(cadr sdat))
(msg . "Transport died?"))
- *configdat* #t)
+ *configdat* #t)
(exit))
(loop start-time
(equal? sdat last-sdat)
sdat)))))))
- (iface (car server-info))
+ (iface (car server-info))
(port (cadr server-info))
(last-access 0)
(server-timeout (server:expiration-timeout))
(server-going #f)
(server-log-file (args:get-arg "-log"))) ;; always set when we are a server
Index: margs-inc.scm
==================================================================
--- margs-inc.scm
+++ margs-inc.scm
@@ -30,11 +30,11 @@
(define (args:get-arg-from ht arg . default)
(if (null? default)
(hash-table-ref/default ht arg #f)
(hash-table-ref/default ht arg (car default))))
-(define (args:usage . args)
+#;(define (args:usage . args)
(if (> (length args) 0)
(apply print "ERROR: " args))
(if (string? help)
(print help)
(print "Usage: " (car (argv)) " ... "))
Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -141,10 +141,30 @@
;;======================================================================
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")
+;; globals
+(define *writes-total-delay* 0)
+(define *exit-started* #f)
+
+(define *tim* (iup:timer))
+
+;; The watchdog is to keep an eye on things like db sync etc.
+;;
+
+;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+(define *watchdog* (make-thread
+ (lambda ()
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (print " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (common:watchdog)))
+ "Watchdog thread"))
+
(include "api-inc.scm")
(include "archive-inc.scm")
(include "client-inc.scm")
(include "common-inc.scm")
(include "configf-inc.scm")
@@ -151,18 +171,20 @@
(include "db-inc.scm")
(include "dcommon-inc.scm")
(include "dashboard-tests-inc.scm")
(include "env-inc.scm")
(include "ezsteps-inc.scm")
+(include "gutils-inc.scm")
(include "http-transport-inc.scm")
(include "items-inc.scm")
(include "keys-inc.scm")
(include "launch-inc.scm")
(include "margs-inc.scm")
(include "mt-inc.scm")
(include "ods-inc.scm")
(include "pgdb-inc.scm")
+(include "portlogger-inc.scm")
(include "process-inc.scm")
(include "rmt-inc.scm")
(include "runconfig-inc.scm")
(include "runs-inc.scm")
(include "server-inc.scm")
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -474,23 +474,11 @@
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
(if targ (setenv "MT_TARGET" targ)))
-;; The watchdog is to keep an eye on things like db sync etc.
-;;
-
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define *watchdog* (make-thread
- (lambda ()
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (print " message: " ((condition-property-accessor 'exn 'message) exn)))
- (common:watchdog)))
- "Watchdog thread"))
+;; watchdog was here
;;(if (not (args:get-arg "-server"))
;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
(let* ((no-watchdog-args
'("-list-runs"
ADDED portlogger-inc.scm
Index: portlogger-inc.scm
==================================================================
--- /dev/null
+++ portlogger-inc.scm
@@ -0,0 +1,180 @@
+
+;; Copyright 2006-2014, 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 .
+;;
+
+;; lsof -i
+
+(define (portlogger:open-db fname)
+ (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
+ (exists (common:file-exists? fname))
+ (db (if avail
+ (sqlite3:open-database fname)
+ (begin
+ (system (conc "rm -f " fname))
+ (sqlite3:open-database fname))))
+ (handler (sqlite3:make-busy-timeout 136000))
+ (canwrite (file-write-access? fname)))
+ ;; (db-init (lambda ()
+ ;; (sqlite3:execute
+ ;; db
+ ;; "CREATE TABLE IF NOT EXISTS ports (
+ ;; port INTEGER PRIMARY KEY,
+ ;; state TEXT DEFAULT 'not-used',
+ ;; fail_count INTEGER DEFAULT 0,
+ ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );"))))
+ (sqlite3:set-busy-handler! db handler)
+ (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
+ ;; (if (not exists) ;; needed with IF NOT EXISTS?
+ (sqlite3:execute
+ db
+ "CREATE TABLE IF NOT EXISTS ports (
+ port INTEGER PRIMARY KEY,
+ state TEXT DEFAULT 'not-used',
+ fail_count INTEGER DEFAULT 0,
+ update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
+ db))
+
+(define (portlogger:open-run-close proc . params)
+ (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db"))
+ (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
+ (handle-exceptions
+ exn
+ (begin
+ ;; (release-dot-lock fname)
+ (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it
+ (print-call-chain (current-error-port)))
+ (let* (;; (lock (obtain-dot-lock fname 2 9 10))
+ (db (portlogger:open-db fname))
+ (res (apply proc db params)))
+ (sqlite3:finalize! db)
+ ;; (release-dot-lock fname)
+ res))))
+
+;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
+(define (portlogger:take-port db portnum)
+ (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);"))
+ (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
+ (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;"))
+ (res (sqlite3:with-transaction
+ db
+ (lambda ()
+ ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;")
+ (let* ((curr #f)
+ (res #f))
+ (set! curr (sqlite3:fold-row
+ (lambda (var curr)
+ (or curr var curr))
+ "not-tried"
+ qry3
+ portnum))
+ ;; (print "curr=" curr)
+ (set! res (case (string->symbol curr)
+ ((released) (sqlite3:execute qry2 "taken" portnum) 'taken)
+ ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken)
+ ((taken) 'already-taken)
+ ((failed) 'failed)
+ (else 'error)))
+ ;; (print "res=" res)
+ res)))))
+ (sqlite3:finalize! qry1)
+ (sqlite3:finalize! qry2)
+ (sqlite3:finalize! qry3)
+ res))
+
+(define (portlogger:get-prev-used-port db)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* "Continuing anyway.")
+ #f)
+ (sqlite3:fold-row
+ (lambda (var curr)
+ (or curr var curr))
+ #f
+ db
+ "SELECT (port) FROM ports WHERE state='released' LIMIT 1;")))
+
+(define (portlogger:find-port db)
+ (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
+ (if (and val
+ (string->number val))
+ (string->number val)
+ 32768)))
+ (portnum (or (portlogger:get-prev-used-port db)
+ (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
+ (random (- 64000 lowport))))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* "Continuing anyway."))
+ (portlogger:take-port db portnum))
+ portnum))
+
+;; set port to "released", "failed" etc.
+;;
+(define (portlogger:set-port db portnum value)
+ (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum))
+
+;; set port to failed (attempted to take but got error)
+;;
+(define (portlogger:set-failed db portnum)
+ (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (portlogger:main . args)
+ (let* ((dbfname (conc "/tmp/." (current-user-name) "-portlogger.db"))
+ (db (portlogger:open-db dbfname))
+ (numargs (length args))
+ (result
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (print-call-chain (current-error-port))
+ #f)
+ (case (string->symbol (car args)) ;; commands with two or more params
+ ((take)(portlogger:take-port db (string->number (cadr args))))
+ ((find)(portlogger:find-port db))
+ ((set) (let ((port (cadr args))
+ (state (caddr args)))
+ (portlogger:set-port db
+ (if (number? port) port (string->number port))
+ state)
+ state))
+ ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))
+ (sqlite3:finalize! db)
+ result))
+
+;; (print (apply portlogger:main (cdr (argv))))