Overview
| Comment: | Some basics in place |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.70-ndboard |
| Files: | files | file ages | folders |
| SHA1: |
a28c78bc9ed47516005136c7c81c4b99 |
| User & Date: | matt on 2022-10-30 19:42:55 |
| Other Links: | branch diff | manifest | tags |
Context
|
2022-10-30
| ||
| 20:55 | Switch dashboard.scm to use treemod. Updated Makefile deps for newdashboard. check-in: f09a7b7261 user: matt tags: v1.70-ndboard | |
| 19:42 | Some basics in place check-in: a28c78bc9e user: matt tags: v1.70-ndboard | |
| 18:11 | Another attempt at newdashboard check-in: 8cb7f297ed user: matt tags: v1.70-ndboard | |
Changes
Modified Makefile from [cf2bdc698c] to [7a88c5f300].
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm tdb.scm client.scm mt.scm \
ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
| | > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm tdb.scm client.scm mt.scm \
ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \
treemod.scm
all : $(PREFIX)/bin/.$(ARCHSTR) mtest ndboard dboard mtut tcmt
# dbmod.import.o is just a hack here
mofiles/dbfile.o : mofiles/debugprint.o dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
|
| ︙ | ︙ |
Modified newdashboard.scm from [aeabc5cbc2] to [a928a0a749].
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; 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 <http://www.gnu.org/licenses/>. ;;====================================================================== | > > > > > > | > > > > | | > > > > > > | | | | | > > | | | | < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
;; (declare (uses common))
;; (declare (uses megatest-version))
(declare (uses mtargs))
(declare (uses treemod))
(use srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors)
(use format
(prefix iup iup:)
canvas-draw)
(import canvas-draw-iup)
;; (debug:setup)
(module ndboard
*
(import scheme
chicken
data-structures
format
(prefix iup iup:)
canvas-draw
canvas-draw-iup
srfi-1 posix regex regex-case
srfi-69 typed-records sparse-vectors ;; defstruct
treemod
(prefix mtargs args:)
)
(include "megatest-version.scm")
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
;; (declare (uses dcommon))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
(exit)))
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.newdashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
| < < > > > > > > > > > > > > > > > > > > > > | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | < | < | < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < | < > | < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | | < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | > > | | > | > > > > > > > | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
(exit)))
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.newdashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; areas
;;
(define (get-areas-file)
(conc (get-environment-variable "HOME")"/.ndboard/areas.scm"))
(define (get-areas)
(let* ((areas-file (get-areas-file)))
(if (file-exists? areas-file)
(with-input-from-file areas-file read))))
;; gui utils
;;
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
(define (iuplistbox-fill-list lb items . default)
(let ((i 1)
(selected-item (if (null? default) #f (car default))))
(iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
(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" item))) ;; (number->string i))))
(set! i (+ i 1)))
items)
i))
;; simple widget registration and finding
(define *widgets* (make-hash-table))
(define (add-widget name wgt)
(hash-table-set! *widgets* name wgt)
wgt)
(define (get-widget name)
(hash-table-ref/default *widgets* name #f))
(define (pad-list l n)(append l (make-list (- n (length l)))))
;; the main tree, everything starts from here
;;
(define (main-tree)
(iup:treebox
#:value 0
#:title "Areas"
#:expand "YES"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(print "do nothing..."))))
(define (runs window-id)
(iup:hbox
(add-widget "main-tree" (main-tree))
;;
))
(define (runs-init)
(let* ((areas (get-areas))
(tb (get-widget "main-tree")))
(for-each
(lambda (areadat)
(tree:add-node tb "Areas" `(,(car areadat))))
areas)))
;; Browse and control a single run
;;
(define (runcontrol window-id)
(iup:hbox))
;; Main Panel
(define (main-panel window-id)
(iup:dialog
#:title "Megatest Control Panel"
;; #:menu (dcommon:main-menu)
#:shrink "YES"
(let ((tabtop (iup:tabs
(add-widget "runs" (runs window-id))
;; (tests window-id)
(runcontrol window-id)
;; (mtest *toppath* window-id)
;; (rconfig window-id)
)))
(iup:attribute-set! tabtop "TABTITLE0" "Runs")
;; (iup:attribute-set! tabtop "TABTITLE1" "Tests")
(iup:attribute-set! tabtop "TABTITLE1" "Run Control")
;; (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
;; (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
tabtop)))
(define *current-window-id* 0)
(define (newdashboard dbstruct)
(let* ((data (make-hash-table))
(keys '()) ;; (db:get-keys dbstruct))
(runname "%")
(testpatt "%")
(keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
(states '())
(statuses '())
(nextmintime (current-milliseconds))
(my-window-id *current-window-id*))
(set! *current-window-id* (+ 1 *current-window-id*))
;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
(iup:show (main-panel my-window-id))
(runs-init)
;; Yes, running iup:show will pop up a new panel
;; (iup:show (main-panel my-window-id))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
;; Want to dedicate no more than 50% of the time to this so skip if
;; 2x delta time has not passed since last query
#t
#;(if (< nextmintime (current-milliseconds))
(let* ((starttime (current-milliseconds))
;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
(endtime (current-milliseconds)))
(set! nextmintime (+ endtime (* 2 (- endtime starttime))))
;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
)
(print "Server overloaded"))))))
)
;;======================================================================
;; D A S H B O A R D
;;======================================================================
(import ndboard)
(newdashboard #f)
(iup:main-loop)
|
Added treemod.scm version [54272b22b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
;;======================================================================
;; Copyright 2006-2013, 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(declare (unit treemod))
;; (declare (uses margs))
;; (declare (uses launch))
;; ;; (declare (uses megatest-version))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; ;; (declare (uses synchash))
;; (declare (uses dcommon))
;;
;; (include "megatest-version.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(module treemod
*
(import
scheme
chicken
data-structures
(prefix iup iup:)
canvas-draw
iup
regex
srfi-1
srfi-13
format
)
;;======================================================================
;; T R E E S T U F F
;;======================================================================
;; path is a list of nodes, each the child of the previous
;; this routine returns the id so another node can be added
;; either as a leaf or as a branch
;;
;; BUG: This needs a stop sensor for when a branch is exhausted
;;
(define (tree:find-node obj path)
;; start at the base of the tree
(if (null? path)
#f ;; or 0 ????
(let loop ((hed (car path))
(tal (cdr path))
(depth 0)
(nodenum 0))
;; nodes in iup tree are 100% sequential so iterate over nodenum
(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
(let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
(node-title (iup:attribute obj (conc "TITLE" nodenum))))
(if (and (equal? depth node-depth)
(equal? hed node-title)) ;; yep, this is the one!
(if (null? tal) ;; end of the line
nodenum
(loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
;; this is the case where we found part of the hierarchy but not
;; all of it, i.e. the node-depth went from deep to less deep
(if (> depth node-depth) ;; (+ 1 node-depth))
#f
(loop hed tal depth (+ nodenum 1)))))
#f))))
;; top is the top node name zeroeth node VALUE=0
(define (tree:add-node obj top nodelst #!key (userdata #f))
(let ((curr-top (iup:attribute obj "TITLE0")))
(if (or (not (string? curr-top))
(string-null? curr-top)
(string-match "^\\s*$" curr-top))
(iup:attribute-set! obj "ADDBRANCH0" top))
(cond
((not (equal? top (iup:attribute obj "TITLE0")))
(print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
((null? nodelst))
(else
(let loop ((hed (car nodelst))
(tal (cdr nodelst))
(depth 1)
(pathl (list top)))
;; Because the tree dialog changes node numbers when
;; nodes are added or removed we must look up nodes
;; each and every time. 0 is the top node so default
;; to that.
(let* ((newpath (append pathl (list hed)))
(parentnode (tree:find-node obj pathl))
(nodenum (tree:find-node obj newpath)))
;; Add the branch under lastnode if not found
(if (not nodenum)
(begin
(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE?
(if userdata
(iup:attribute-set! obj (conc "USERDATA" parentnode) userdata))
(if (null? tal)
#t
;; reset to top
(loop (car nodelst)(cdr nodelst) 1 (list top))))
(if (null? tal) ;; if null here then this path has already been added
#t
(loop (car tal)(cdr tal)(+ depth 1) newpath)))))))))
(define (tree:node->path obj nodenum)
(let loop ((currnode 0)
(path '()))
(let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode))))
(node-title (iup:attribute obj (conc "TITLE" currnode)))
(trimpath (if (and (not (null? path))
(> (length path) node-depth))
(take path node-depth)
path))
(newpath (append trimpath (list node-title))))
(if (>= currnode nodenum)
newpath
(loop (+ currnode 1)
newpath)))))
(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
(let ((id (tree:find-node obj (cons top node-path))))
(print "Found node to remove " id " for path " top " " node-path)
(iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
)
#|
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#:selection-cb
(lambda (obj id state)
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id (cdr run-path))))
(if run-id
(begin
(dboard:data-curr-run-id-set! data run-id)
(dashboard:update-run-summary-tab)))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
))))
|#
|