Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -32,11 +32,11 @@
# portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
SRCFILES=
# removed from MSRCFILES: ftail.scm
# module source files
-MSRCFILES = rmtmod.scm commonmod.scm apimod.scm archivemod.scm clientmod.scm dbmod.scm dcommonmod.scm envmod.scm ezstepsmod.scm itemsmod.scm keysmod.scm launchmod.scm odsmod.scm processmod.scm runconfigmod.scm runsmod.scm servermod.scm subrunmod.scm tasksmod.scm testsmod.scm vgmod.scm megamod.scm
+MSRCFILES = rmtmod.scm commonmod.scm apimod.scm archivemod.scm clientmod.scm dbmod.scm dcommonmod.scm envmod.scm ezstepsmod.scm itemsmod.scm keysmod.scm launchmod.scm odsmod.scm processmod.scm runconfigmod.scm runsmod.scm servermod.scm subrunmod.scm tasksmod.scm testsmod.scm vgmod.scm treemod.scm megamod.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -195,10 +195,12 @@
(include "subrun-inc.scm")
(include "tasks-inc.scm")
(include "tdb-inc.scm")
(include "tests-inc.scm")
(include "vg-inc.scm")
+(include "tree-inc.scm")
+
;; (include "js-path.scm") ;; moved into init procedure in tests-inc.scm
)
;; http-transport:server-dat definition moved to common_records.scm
;; bunch of small functions factored out of send-receive to make debug easier
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -1,6 +1,6 @@
-; Copyright 2006-2017, Matthew Welland.
+;; Copyright 2006-2017, 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
ADDED tree-inc.scm
Index: tree-inc.scm
==================================================================
--- /dev/null
+++ tree-inc.scm
@@ -0,0 +1,156 @@
+;;======================================================================
+;; 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 .
+;;
+;;======================================================================
+
+;; (use format)
+;; (require-library iup)
+;; (import (prefix iup iup:))
+;; (use canvas-draw)
+;;
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69)
+;; (import (prefix sqlite3 sqlite3:))
+;;
+;; (declare (unit tree))
+;; (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 "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+;;
+;; ;;======================================================================
+;; 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)
+ ))))
+|#
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -37,6 +37,7 @@
(declare (uses dcommon))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
+
ADDED treemod.scm
Index: treemod.scm
==================================================================
--- /dev/null
+++ treemod.scm
@@ -0,0 +1,32 @@
+;;======================================================================
+;; 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 .
+;;
+;;======================================================================
+
+(declare (unit treemod))
+
+(module treemod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix iup iup:)) ;; (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable)
+;; (import commonmod) ;;; DO NOT ALLOW rmt*scm TO DEPEND ON common*scm!!!!
+
+
+;; (include "common_records.scm")
+)