Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -7,11 +7,11 @@
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
-(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3)
+(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3 call-with-environment-variables)
(require-extension sqlite3 regex posix)
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
@@ -35,22 +35,28 @@
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
-(define *db-keys* #f)
-(define *configinfo* #f)
-(define *configdat* #f)
-(define *toppath* #f)
-(define *already-seen-runconfig-info* #f)
-(define *waiting-queue* (make-hash-table))
-(define *test-meta-updated* (make-hash-table))
-(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
-(define *passnum* 0) ;; when running track calls to run-tests or similar
-(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
-(define *alt-log-file* #f) ;; used by -log
-(define *common:denoise* (make-hash-table)) ;; for low noise printing
+;; (define *db-keys* #f)
+;; (define *configinfo* #f)
+;; (define *configdat* #f)
+;; (define *toppath* #f)
+;; (define *already-seen-runconfig-info* #f)
+;; (define *waiting-queue* (make-hash-table))
+;; (define *test-meta-updated* (make-hash-table))
+;; (define *globalexitstatus* 0) ;; attempt to work around possible thread issues
+;; (define *passnum* 0) ;; when running track calls to run-tests or similar
+;; (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
+;; (define *alt-log-file* #f) ;; used by -log
+;; (define *common:denoise* (make-hash-table)) ;; for low noise printing
+
+;; All the above *theoretically* replaced by ...
+(define *testsuite-data* (make-hash-table)) ;; area-path => testsuite-vector < toppath linktree configdat envvars dbstruct >
+
+;; MULTI-TESTSUITE support, use when the env-vars are in use (set up and take down using call-with-environment-variables.)
+(define *testsuite-mutex* (make-mutex))
;; DATABASE
(define *dbstruct-db* #f)
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
@@ -118,10 +124,91 @@
;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
;; Generic path database
(define *fdb* #f)
+
+;;======================================================================
+;; G E N E R I C S E T U P F O R A T E S T S U I T E
+;;======================================================================
+
+;; set up the very basics needed for doing anything here.
+;; this returns a common_records:testsuite record: < toppath linktree configdat envvars >
+;;
+(define (common:multi-setup-for-run #!key (force #f)(configdat-in #f))
+ (mutex-lock! *testsuite-mutex*)
+ (let* ((configinfo (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
+ (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
+ ".megatest.cfg")))
+ (if (file-exists? alistconfig)
+ (list (configf:read-alist alistconfig)
+ (get-environment-variable "MT_RUN_AREA_HOME"))
+ #f))
+ #f) ;; no config cached - give up
+ (find-and-read-config
+ (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
+ environ-patt: "env-override"
+ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
+ pathenvvar: "MT_RUN_AREA_HOME")))
+ (configdat (if (car configinfo)(car configinfo) #f))
+ (toppath (if (car configinfo)(cadr configinfo) #f))
+ (linktree (configf:lookup configdat "setup" "linktree")) ;; link tree is critical
+ (failed #f))
+ (if linktree
+ (if (not (file-exists? linktree))
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
+ (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (set! failed #t))
+ (create-directory linktree #t))))
+ (begin
+ (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
+ (set! failed #t)))
+ (if linktree
+ (let ((dbdir (or (configf:lookup configdat "setup" "dbdir") ;; not really supported yet, placeholder only
+ (conc linktree "/.db"))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
+ (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (set! failed #t))
+ (if (not (directory-exists? dbdir))(create-directory dbdir))))
+ ;; (setenv "MT_LINKTREE" linktree))
+ (begin
+ (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
+ (set! failed #t)))
+ (if (not (and toppath
+ (directory-exists? toppath)))
+ (begin
+ (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
+ (set! failed #t)))
+ (mutex-unlock! *testsuite-mutex*)
+ (let ((testsuite-data (vector toppath linktree configinfo
+ (list (cons "MT_LINKTREE" linktree)
+ (cons "MT_RUN_AREA_HOME" toppath))
+ #f)))
+ (if failed
+ #f
+ (begin
+ (hash-table-set! *testsuite-data* toppath testsuite-data)
+ testsuite-data)))))
+
+;; get the vars from the testsuite-data envvars store and run proc
+;;
+(define (common:with-vars testsuite-data proc . additional-vars)
+ (mutex-lock! *testsuite-mutex*)
+ (let* ((envvars (append (common_records:testsuite-get-envvars testsuite-data)
+ additional-vars))
+ (res (call-with-environment-variables envvars proc)))
+ (mutex-unlock! *testsuite-mutex*)
+ res))
;;======================================================================
;; L O C K E R S A N D B L O C K E R S
;;======================================================================
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -97,5 +97,27 @@
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
+;;======================================================================
+;; T E S T S U I T E R E C O R D S
+;;======================================================================
+
+;; make-vector-record common_records testsuite toppath linktree configdat envvars
+(define (make-common_records:testsuite)(make-vector 5))
+(define-inline (common_records:testsuite-get-toppath vec) (vector-ref vec 0))
+(define-inline (common_records:testsuite-get-linktree vec) (vector-ref vec 1))
+(define-inline (common_records:testsuite-get-configdat vec) (vector-ref vec 2))
+(define-inline (common_records:testsuite-get-envvars vec) (vector-ref vec 3))
+(define-inline (common_records:testsuite-get-dbstruct vec) (vector-ref vec 4))
+(define-inline (common_records:testsuite-set-toppath! vec val)(vector-set! vec 0 val))
+(define-inline (common_records:testsuite-set-linktree! vec val)(vector-set! vec 1 val))
+(define-inline (common_records:testsuite-set-configdat! vec val)(vector-set! vec 2 val))
+(define-inline (common_records:testsuite-set-envvars! vec val)(vector-set! vec 3 val))
+(define-inline (common_records:testsuite-set-dbstruct! vec val)(vector-set! vec 4 val))
+
+(define (common_records:testsuite-add-envvar! vec var val)
+ (let ((envvars (cons (cons var val)
+ (or (common_records:testsuite-get-envvars vec) '()))))
+ (common_records:testsuite-set-envvars! vec envvars)
+ envvars))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -451,11 +451,11 @@
;; have chicken/egg scenario. need to read megatest.config then read it again. Going to
;; pass on that idea for now
;; special case
(if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call
(begin
- (set! *configinfo* (or (if (get-environment-variable "MT_MDINFO") ;; we are inside a test - do not reprocess configs
+ (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
(let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
(get-environment-variable "MT_TARGET") "/"
(get-environment-variable "MT_RUNNAME") "/"
".megatest.cfg")))
(if (file-exists? alistconfig)
@@ -510,14 +510,71 @@
(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
(exit 1)))
)))
*toppath*)
-(define (launch:cache-config)
+;; set up the very basics needed for doing anything here.
+(define (launch:multi-setup-for-run #!key (force #f)(configdat-in #f))
+ (mutex-lock! *testsuite-mutex*)
+ (let* ((configinfo (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
+ (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
+ ".megatest.cfg")))
+ (if (file-exists? alistconfig)
+ (list (configf:read-alist alistconfig)
+ (get-environment-variable "MT_RUN_AREA_HOME"))
+ #f))
+ #f) ;; no config cached - give up
+ (find-and-read-config
+ (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
+ environ-patt: "env-override"
+ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
+ pathenvvar: "MT_RUN_AREA_HOME")))
+ (configdat (if (car configinfo)(car configinfo) #f))
+ (toppath (if (car configinfo)(cadr configinfo) #f))
+ (linktree (configf:lookup configdat "setup" "linktree"))) ;; link tree is critical
+ (if linktree
+ (if (not (file-exists? linktree))
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
+ (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (create-directory linktree #t))))
+ (begin
+ (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
+ (exit 1)))
+ (if linktree
+ (let ((dbdir (or (configf:lookup configdat "setup" "dbdir") ;; not really supported yet, placeholder only
+ (conc linktree "/.db"))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
+ (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (if (not (directory-exists? dbdir))(create-directory dbdir))))
+ ;; (setenv "MT_LINKTREE" linktree))
+ (begin
+ (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
+ ;; (exit 1)
+ )
+ )
+ (if (not (and toppath
+ (directory-exists? toppath)))
+ ;; (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (begin
+ (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))
+ ;; (exit 1)))
+ (mutex-unlock! *testsuite-mutex*)
+ configinfo))
+
+(define (launch:cache-config testsuite-data)
;; if we have a linktree and -runtests and -target and the directory exists dump the config
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
- (if (and *configdat*
+ (if (and testsuite-data ;; *configdat*
(args:get-arg "-runtests"))
(let* ((linktree (get-environment-variable "MT_LINKTREE"))
(target (common:args-get-target))
(runname (or (args:get-arg "-runname")
(args:get-arg ":runname")))
@@ -533,11 +590,11 @@
runname
(file-exists? fulldir))
(let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
(targfile (conc fulldir "/.megatest.cfg")))
(debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
- (configf:write-alist *configdat* tmpfile)
+ (configf:write-alist testsuite-data tmpfile)
(system (conc "ln -sf " tmpfile " " targfile))
)))))))
(define (get-best-disk confdat)
(let* ((disks (hash-table-ref/default confdat "disks" #f))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -300,36 +300,36 @@
(define *time-zero* (current-seconds))
(define *watchdog*
(make-thread
(lambda ()
(thread-sleep! 0.05) ;; delay for startup
- (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))
+ (let (;; (legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds)))
(let loop ()
;; sync for filesystem local db writes
;;
(let ((start-time (current-seconds))
(servers-started (make-hash-table)))
- (for-each
- (lambda (run-id)
- (mutex-lock! *db-multi-sync-mutex*)
- (if (and legacy-sync
- (hash-table-ref/default *db-local-sync* run-id #f))
- ;; (if (> (- start-time last-write) 5) ;; every five seconds
- (begin ;; let ((sync-time (- (current-seconds) start-time)))
- (db:multi-db-sync (list run-id) 'new2old)
- (if (common:low-noise-print 30 "sync new to old")
- (let ((sync-time (- (current-seconds) start-time)))
- (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
- ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
- ;; (begin
- ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
- ;; (server:kind-run run-id)))))
- (hash-table-delete! *db-local-sync* run-id)))
- (mutex-unlock! *db-multi-sync-mutex*))
- (hash-table-keys *db-local-sync*))
+ ;; (for-each
+ ;; (lambda (run-id)
+ ;; (mutex-lock! *db-multi-sync-mutex*)
+ ;; (if (and legacy-sync
+ ;; (hash-table-ref/default *db-local-sync* run-id #f))
+ ;; ;; (if (> (- start-time last-write) 5) ;; every five seconds
+ ;; (begin ;; let ((sync-time (- (current-seconds) start-time)))
+ ;; (db:multi-db-sync (list run-id) 'new2old)
+ ;; (if (common:low-noise-print 30 "sync new to old")
+ ;; (let ((sync-time (- (current-seconds) start-time)))
+ ;; (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
+ ;; ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
+ ;; ;; (begin
+ ;; ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
+ ;; ;; (server:kind-run run-id)))))
+ ;; (hash-table-delete! *db-local-sync* run-id)))
+ ;; (mutex-unlock! *db-multi-sync-mutex*))
+ ;; (hash-table-keys *db-local-sync*))
(if (and debug-mode
(> (- start-time last-time) 60))
(begin
(set! last-time start-time)
(debug:print-info 1 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
@@ -655,11 +655,12 @@
'("-list-servers"
"-stop-server"
"-show-cmdinfo"
"-list-runs"
"-ping")))
- (if (launch:setup-for-run)
+ (let ((testsuite-data (common:multi-setup-for-run)))
+ (if testsuite-data ;; (launch:setup-for-run)
(let ((run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
@@ -668,11 +669,11 @@
(begin
;; (if run-id
;; (client:launch run-id)
;; (client:launch 0) ;; without run-id we'll start a server for "0"
#t
- ))))))
+ )))))))
;; MAY STILL NEED THIS
;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -67,34 +67,15 @@
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
-(if (not (launch:setup-for-run))
- (begin
- (print "Failed to find megatest.config, exiting")
- (exit 1)))
-
-;; (if (args:get-arg "-host")
-;; (begin
-;; (set! *runremote* (string-split (args:get-arg "-host" ":")))
-;; (client:launch))
-;; (client:launch))
-
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
-(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
-(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
- local: #t))
-(define *db-file-path* (db:dbfile-path 0))
-
-;; HACK ALERT: this is a hack, please fix.
-(define *read-only* (not (file-read-access? *db-file-path*)))
-
(debug:setup)
(define *tim* (iup:timer))
(define *ord* #f)
@@ -120,144 +101,24 @@
items)
i))
(define (pad-list l n)(append l (make-list (- n (length l)))))
-
(define (mkstr . x)
(string-intersperse (map conc x) ","))
-(define (update-search x val)
- (hash-table-set! *searchpatts* x val))
-
-;; mtest is actually the megatest.config file
-;;
-(define (mtest window-id)
- (let* ((curr-row-num 0)
- (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))
- (keys-matrix (dcommon:keys-matrix rawconfig))
- (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
- (jobtools-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 3))
- (validvals-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 2
- #:numcol-visible 1
- #:numlin-visible 2))
- (envovrd-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- (disks-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- )
- (iup:attribute-set! disks-matrix "0:0" "Disk Name")
- (iup:attribute-set! disks-matrix "0:1" "Disk Path")
- (iup:attribute-set! disks-matrix "WIDTH1" "120")
- (iup:attribute-set! disks-matrix "WIDTH0" "100")
- (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
-
- ;; fill in existing info
- (for-each
- (lambda (mat fname)
- (set! curr-row-num 1)
- (for-each
- (lambda (var)
- (iup:attribute-set! mat (conc curr-row-num ":0") var)
- (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
- (set! curr-row-num (+ curr-row-num 1)))
- (configf:section-vars rawconfig fname)))
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
- (list "setup" "jobtools" "validvalues" "env-override" "disks"))
-
- (for-each
- (lambda (mat)
- (iup:attribute-set! mat "0:1" "Value")
- (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES")
- (iup:attribute-set! mat "WIDTH1" "120")
- (iup:attribute-set! mat "WIDTH0" "100")
- )
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
-
- (iup:attribute-set! validvals-matrix "WIDTH1" "290")
- (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
-
- (iup:vbox
- (iup:hbox
-
- (iup:vbox
- (let ((tabs (iup:tabs
- ;; The required tab
- (iup:hbox
- ;; The keys
- (iup:frame
- #:title "Keys (required)"
- (iup:vbox
- (iup:label (conc "Set the fields for organising your runs\n"
- "here. Note: can only be changed before\n"
- "running the first run when megatest.db\n"
- "is created."))
- keys-matrix))
- (iup:vbox
- ;; The setup section
- (iup:frame
- #:title "Setup"
- (iup:vbox
- (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
- "linktree : directory where linktree will be created."))
- setup-matrix))
- ;; The jobtools
- (iup:frame
- #:title "Jobtools"
- (iup:vbox
- (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
- "useshell : use system to run your launcher\n"
- "workhosts : spread jobs out on these hosts"))
- jobtools-matrix))
- ;; The disks
- (iup:frame
- #:title "Disks"
- (iup:vbox
- (iup:label (conc "Enter names and existing paths of locations to run tests"))
- disks-matrix))))
- ;; The optional tab
- (iup:vbox
- ;; The Environment Overrides
- (iup:frame
- #:title "Env override"
- envovrd-matrix)
- ;; The valid values
- (iup:frame
- #:title "Validvalues"
- validvals-matrix)
- ))))
- (iup:attribute-set! tabs "TABTITLE0" "Required settings")
- (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
- tabs))
- ))))
-
-;; The runconfigs.config file
-;;
-(define (rconfig window-id)
- (iup:vbox
- (iup:frame #:title "Default")))
+;;======================================================================
+;; G L O B A L D A T A S T R U C T U R E ? ?
+;;======================================================================
+
+;; testsuite nick-> [ path
+;; linktree
+;; target/runname -> [ id (ht) -> [ runname
+;; tests -> [ id (ht) -> state
+;; status
+;; item_path
+;; fulldat -> [ remaining data ]
;;======================================================================
;; T E S T S
;;======================================================================
@@ -264,314 +125,16 @@
(define (tree-path->test-id path)
(if (not (null? path))
(hash-table-ref/default (dboard:data-get-path-test-ids *data*) path #f)
#f))
-(define (test-panel window-id)
- (let* ((curr-row-num 0)
- (viewlog (lambda (x)
- (if (file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
- (command-launch-button (iup:button "Execute!"
- ;; #:expand "HORIZONTAL"
- #:size "50x"
- #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
- " -runtests " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
- " -testpatt " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (run-info-matrix (iup:matrix
- #:expand "YES"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin 4
- #:numcol-visible 1
- #:numlin-visible 4
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status))))
- (test-info-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 7
- #:numcol-visible 1
- #:numlin-visible 7))
- (test-run-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (meta-dat-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (steps-matrix (iup:matrix
- #:expand "YES"
- #:numcol 6
- #:numlin 50
- #:numcol-visible 6
- #:numlin-visible 8))
- (data-matrix (iup:matrix
- #:expand "YES"
- #:numcol 8
- #:numlin 50
- #:numcol-visible 8
- #:numlin-visible 8))
- (updater (lambda (testdat)
- (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
-
- ;; Set the updater in updaters
- (hash-table-set! (dboard:data-get-updaters *data*) window-id updater)
- ;;
- (for-each
- (lambda (mat)
- ;; (iup:attribute-set! mat "0:1" "Value")
- ;; (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "HEIGHT0" 0)
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
- ;; (iup:attribute-set! mat "WIDTH1" "120")
- ;; (iup:attribute-set! mat "WIDTH0" "100"))
- (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
-
- ;; Steps matrix
- (iup:attribute-set! steps-matrix "0:1" "Step Name")
- (iup:attribute-set! steps-matrix "0:2" "Start")
- (iup:attribute-set! steps-matrix "WIDTH2" "40")
- (iup:attribute-set! steps-matrix "0:3" "End")
- (iup:attribute-set! steps-matrix "WIDTH3" "40")
- (iup:attribute-set! steps-matrix "0:4" "Status")
- (iup:attribute-set! steps-matrix "WIDTH4" "40")
- (iup:attribute-set! steps-matrix "0:5" "Duration")
- (iup:attribute-set! steps-matrix "WIDTH5" "40")
- (iup:attribute-set! steps-matrix "0:6" "Log File")
- (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
- ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
- ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
-
- ;; Data matrix
- ;;
- (let ((rownum 1))
- (for-each
- (lambda (x)
- (iup:attribute-set! data-matrix (conc "0:" rownum) x)
- (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
- (set! rownum (+ rownum 1)))
- (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
- (iup:attribute-set! data-matrix "REDRAW" "ALL")
-
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (keys (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (iup:attribute-set! mat (conc rownum ":0") key)
- (set! rownum (+ rownum 1)))
- keys)
- (iup:attribute-set! mat "REDRAW" "ALL")))
- (list
- (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
- (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
- (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
- (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
-
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- run-info-matrix
- test-info-matrix)
- ;; test-info-matrix)
- (iup:vbox
- test-run-matrix
- meta-dat-matrix))
- (iup:vbox
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
- (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
- (iup:hbox
- (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
- (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
- (iup:hbox
- ;; hiup:split ;; hbox
- ;; #:orientation "HORIZONTAL"
- ;; #:value 300
- command-text-box
- command-launch-button)))
- (iup:vbox
- (let ((tabs (iup:tabs
- steps-matrix
- data-matrix)))
- (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
- (iup:attribute-set! tabs "TABTITLE1" "Test Data")
- tabs)))))
-
-;; Test browser
-(define (tests window-id)
- (iup:split
- (let* ((tb (iup:treebox
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (test-id (tree-path->test-id (cdr run-path))))
- (if test-id
- (hash-table-set! (dboard:data-get-curr-test-ids *data*)
- window-id test-id))
- (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
- (iup:attribute-set! tb "VALUE" "0")
- (iup:attribute-set! tb "NAME" "Runs")
- ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- (dboard:data-set-tests-tree! *data* tb)
- tb)
- (test-panel window-id)))
-
-;; The function to update the fields in the test view panel
-(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
- ;; get test-id
- ;; then get test record
- (if testdat
- (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f))
- (test-data (hash-table-ref/default testdat test-id #f))
- (run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*)
- run-id
- '()))
- (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
- (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
- (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id)))
-
- (if test-data
- (begin
- ;;
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (vals (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (let ((cell (conc rownum ":1")))
- (if (not (equal? (iup:attribute mat cell)(conc key)))
- (begin
- ;; (print "setting cell " cell " in matrix " mat " to value " key)
- (iup:attribute-set! mat cell (conc key))
- (iup:attribute-set! mat "REDRAW" cell)))
- (set! rownum (+ rownum 1))))
- vals)))
- (list
- (list run-info-matrix
- (if test-id
- (list (db:test-get-run_id test-data)
- target
- runname
- "n/a")
- (make-list 4 "")))
- (list test-info-matrix
- (if test-id
- (list test-id
- (db:test-get-testname test-data)
- (db:test-get-item-path test-data)
- (db:test-get-state test-data)
- (db:test-get-status test-data)
- (seconds->string (db:test-get-event_time test-data))
- (db:test-get-comment test-data))
- (make-list 7 "")))
- (list test-run-matrix
- (if test-id
- (list (db:test-get-host test-data)
- (db:test-get-uname test-data)
- (db:test-get-diskfree test-data)
- (db:test-get-cpuload test-data)
- (seconds->hr-min-sec (db:test-get-run_duration test-data)))
- (make-list 5 "")))
- ))
- (dcommon:populate-steps steps-dat steps-matrix))))))
- ;;(list meta-dat-matrix
- ;; (if test-id
- ;; (list (
-
-
-;; db:test-get-id
-;; db:test-get-run_id
-;; db:test-get-testname
-;; db:test-get-state
-;; db:test-get-status
-;; db:test-get-event_time
-;; db:test-get-host
-;; db:test-get-cpuload
-;; db:test-get-diskfree
-;; db:test-get-uname
-;; db:test-get-rundir
-;; db:test-get-item-path
-;; db:test-get-run_duration
-;; db:test-get-final_logf
-;; db:test-get-comment
-;; db:test-get-fullname
;;======================================================================
;; R U N C O N T R O L
;;======================================================================
-;; Overall runs browser
-;;
-(define (runs window-id)
- (let* ((runs-matrix (iup:matrix
- #:expand "YES"
- ;; #:fittosize "YES"
- #:scrollbar "YES"
- #:numcol 100
- #:numlin 100
- #:numcol-visible 7
- #:numlin-visible 7
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
-
- (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
- (iup:attribute-set! runs-matrix "WIDTH0" "100")
-
- (dboard:data-set-runs-matrix! *data* runs-matrix)
- (iup:hbox
- (iup:frame
- #:title "Runs browser"
- (iup:vbox
- runs-matrix)))))
;; Browse and control a single run
;;
(define (runcontrol window-id)
(iup:hbox))
@@ -579,27 +142,16 @@
;;======================================================================
;; D A S H B O A R D
;;======================================================================
;; Main Panel
-(define (main-panel window-id)
+(define (main-panel) ;; window-id)
(iup:dialog
#:title "Megatest Control Panel"
#:menu (dcommon:main-menu)
#:shrink "YES"
- (let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
- (runcontrol window-id)
- (mtest window-id)
- (rconfig window-id)
- )))
- (iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
+ (let ((tabtop (iup:tabs)))
tabtop)))
(define *current-window-id* 0)
(define (newdashboard dbstruct)
@@ -629,7 +181,7 @@
(set! nextmintime (+ endtime (* 2 (- endtime starttime))))
(debug:print 11 "CHANGE(S): " (car changes) "..."))
(debug:print-info 11 "Server overloaded"))))))
(dboard:data-set-updaters! *data* (make-hash-table))
-(newdashboard *dbstruct-local*)
+(iup:show (main-panel))
(iup:main-loop)
ADDED prevnewdashboard.scm
Index: prevnewdashboard.scm
==================================================================
--- /dev/null
+++ prevnewdashboard.scm
@@ -0,0 +1,635 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+(use format numbers)
+(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 (uses margs))
+(declare (uses launch))
+(declare (uses megatest-version))
+(declare (uses gutils))
+(declare (uses db))
+(declare (uses server))
+(declare (uses synchash))
+(declare (uses dcommon))
+(declare (uses tree))
+
+(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
+ version " megatest-version "
+ license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test testid : control test identified by testid
+ -guimonitor : control panel for runs
+
+Misc
+ -rows N : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-rows"
+ "-run"
+ "-test"
+ "-debug"
+ "-host"
+ )
+ (list "-h"
+ "-guimonitor"
+ "-main"
+ "-v"
+ "-q"
+ )
+ args:arg-hash
+ 0))
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+(if (not (launch:setup-for-run))
+ (begin
+ (print "Failed to find megatest.config, exiting")
+ (exit 1)))
+
+;; (if (args:get-arg "-host")
+;; (begin
+;; (set! *runremote* (string-split (args:get-arg "-host" ":")))
+;; (client:launch))
+;; (client:launch))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
+ local: #t))
+(define *db-file-path* (db:dbfile-path 0))
+
+;; HACK ALERT: this is a hack, please fix.
+(define *read-only* (not (file-read-access? *db-file-path*)))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(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))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+ (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+ (hash-table-set! *searchpatts* x val))
+
+;; mtest is actually the megatest.config file
+;;
+(define (mtest window-id)
+ (let* ((curr-row-num 0)
+ (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))
+ (keys-matrix (dcommon:keys-matrix rawconfig))
+ (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
+ (jobtools-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 3))
+ (validvals-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 2
+ #:numcol-visible 1
+ #:numlin-visible 2))
+ (envovrd-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ (disks-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ )
+ (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+ (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+ (iup:attribute-set! disks-matrix "WIDTH1" "120")
+ (iup:attribute-set! disks-matrix "WIDTH0" "100")
+ (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+
+ ;; fill in existing info
+ (for-each
+ (lambda (mat fname)
+ (set! curr-row-num 1)
+ (for-each
+ (lambda (var)
+ (iup:attribute-set! mat (conc curr-row-num ":0") var)
+ (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+ (set! curr-row-num (+ curr-row-num 1)))
+ (configf:section-vars rawconfig fname)))
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+ (list "setup" "jobtools" "validvalues" "env-override" "disks"))
+
+ (for-each
+ (lambda (mat)
+ (iup:attribute-set! mat "0:1" "Value")
+ (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+ (iup:attribute-set! mat "WIDTH1" "120")
+ (iup:attribute-set! mat "WIDTH0" "100")
+ )
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
+
+ (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+ (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
+
+ (iup:vbox
+ (iup:hbox
+
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ ;; The required tab
+ (iup:hbox
+ ;; The keys
+ (iup:frame
+ #:title "Keys (required)"
+ (iup:vbox
+ (iup:label (conc "Set the fields for organising your runs\n"
+ "here. Note: can only be changed before\n"
+ "running the first run when megatest.db\n"
+ "is created."))
+ keys-matrix))
+ (iup:vbox
+ ;; The setup section
+ (iup:frame
+ #:title "Setup"
+ (iup:vbox
+ (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
+ "linktree : directory where linktree will be created."))
+ setup-matrix))
+ ;; The jobtools
+ (iup:frame
+ #:title "Jobtools"
+ (iup:vbox
+ (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
+ "useshell : use system to run your launcher\n"
+ "workhosts : spread jobs out on these hosts"))
+ jobtools-matrix))
+ ;; The disks
+ (iup:frame
+ #:title "Disks"
+ (iup:vbox
+ (iup:label (conc "Enter names and existing paths of locations to run tests"))
+ disks-matrix))))
+ ;; The optional tab
+ (iup:vbox
+ ;; The Environment Overrides
+ (iup:frame
+ #:title "Env override"
+ envovrd-matrix)
+ ;; The valid values
+ (iup:frame
+ #:title "Validvalues"
+ validvals-matrix)
+ ))))
+ (iup:attribute-set! tabs "TABTITLE0" "Required settings")
+ (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
+ tabs))
+ ))))
+
+;; The runconfigs.config file
+;;
+(define (rconfig window-id)
+ (iup:vbox
+ (iup:frame #:title "Default")))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+(define (tree-path->test-id path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:data-get-path-test-ids *data*) path #f)
+ #f))
+
+(define (test-panel window-id)
+ (let* ((curr-row-num 0)
+ (viewlog (lambda (x)
+ (if (file-exists? logfile)
+ ;(system (conc "firefox " logfile "&"))
+ (iup:send-url logfile)
+ (message-window (conc "File " logfile " not found")))))
+ (xterm (lambda (x)
+ (if (directory-exists? rundir)
+ (let ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ "")))
+ (system (conc "cd " rundir
+ ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (message-window (conc "Directory " rundir " not found")))))
+ (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
+ (command-launch-button (iup:button "Execute!"
+ ;; #:expand "HORIZONTAL"
+ #:size "50x"
+ #:action (lambda (x)
+ (let ((cmd (iup:attribute command-text-box "VALUE")))
+ (system (conc cmd " &"))))))
+ (run-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
+ " -runtests " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (remove-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
+ " -testpatt " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (run-info-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:scrollbar "YES"
+ #:numcol 1
+ #:numlin 4
+ #:numcol-visible 1
+ #:numlin-visible 4
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status))))
+ (test-info-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 7
+ #:numcol-visible 1
+ #:numlin-visible 7))
+ (test-run-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (meta-dat-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (steps-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 6
+ #:numlin 50
+ #:numcol-visible 6
+ #:numlin-visible 8))
+ (data-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 8
+ #:numlin 50
+ #:numcol-visible 8
+ #:numlin-visible 8))
+ (updater (lambda (testdat)
+ (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
+
+ ;; Set the updater in updaters
+ (hash-table-set! (dboard:data-get-updaters *data*) window-id updater)
+ ;;
+ (for-each
+ (lambda (mat)
+ ;; (iup:attribute-set! mat "0:1" "Value")
+ ;; (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "HEIGHT0" 0)
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
+ ;; (iup:attribute-set! mat "WIDTH1" "120")
+ ;; (iup:attribute-set! mat "WIDTH0" "100"))
+ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
+
+ ;; Steps matrix
+ (iup:attribute-set! steps-matrix "0:1" "Step Name")
+ (iup:attribute-set! steps-matrix "0:2" "Start")
+ (iup:attribute-set! steps-matrix "WIDTH2" "40")
+ (iup:attribute-set! steps-matrix "0:3" "End")
+ (iup:attribute-set! steps-matrix "WIDTH3" "40")
+ (iup:attribute-set! steps-matrix "0:4" "Status")
+ (iup:attribute-set! steps-matrix "WIDTH4" "40")
+ (iup:attribute-set! steps-matrix "0:5" "Duration")
+ (iup:attribute-set! steps-matrix "WIDTH5" "40")
+ (iup:attribute-set! steps-matrix "0:6" "Log File")
+ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
+ ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
+ ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
+
+ ;; Data matrix
+ ;;
+ (let ((rownum 1))
+ (for-each
+ (lambda (x)
+ (iup:attribute-set! data-matrix (conc "0:" rownum) x)
+ (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
+ (set! rownum (+ rownum 1)))
+ (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
+ (iup:attribute-set! data-matrix "REDRAW" "ALL")
+
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (keys (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (iup:attribute-set! mat (conc rownum ":0") key)
+ (set! rownum (+ rownum 1)))
+ keys)
+ (iup:attribute-set! mat "REDRAW" "ALL")))
+ (list
+ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
+ (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
+ (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
+ (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
+
+ (iup:split
+ #:orientation "HORIZONTAL"
+ (iup:vbox
+ (iup:hbox
+ (iup:vbox
+ run-info-matrix
+ test-info-matrix)
+ ;; test-info-matrix)
+ (iup:vbox
+ test-run-matrix
+ meta-dat-matrix))
+ (iup:vbox
+ (iup:vbox
+ (iup:hbox
+ (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
+ (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
+ (iup:hbox
+ (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
+ (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
+ (iup:hbox
+ ;; hiup:split ;; hbox
+ ;; #:orientation "HORIZONTAL"
+ ;; #:value 300
+ command-text-box
+ command-launch-button)))
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ steps-matrix
+ data-matrix)))
+ (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
+ (iup:attribute-set! tabs "TABTITLE1" "Test Data")
+ tabs)))))
+
+;; Test browser
+(define (tests window-id)
+ (iup:split
+ (let* ((tb (iup:treebox
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (test-id (tree-path->test-id (cdr run-path))))
+ (if test-id
+ (hash-table-set! (dboard:data-get-curr-test-ids *data*)
+ window-id test-id))
+ (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
+ (iup:attribute-set! tb "VALUE" "0")
+ (iup:attribute-set! tb "NAME" "Runs")
+ ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
+ (dboard:data-set-tests-tree! *data* tb)
+ tb)
+ (test-panel window-id)))
+
+;; The function to update the fields in the test view panel
+(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
+ ;; get test-id
+ ;; then get test record
+ (if testdat
+ (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f))
+ (test-data (hash-table-ref/default testdat test-id #f))
+ (run-id (db:test-get-run_id test-data))
+ (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*)
+ run-id
+ '()))
+ (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
+ (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
+ (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id)))
+
+ (if test-data
+ (begin
+ ;;
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (vals (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (let ((cell (conc rownum ":1")))
+ (if (not (equal? (iup:attribute mat cell)(conc key)))
+ (begin
+ ;; (print "setting cell " cell " in matrix " mat " to value " key)
+ (iup:attribute-set! mat cell (conc key))
+ (iup:attribute-set! mat "REDRAW" cell)))
+ (set! rownum (+ rownum 1))))
+ vals)))
+ (list
+ (list run-info-matrix
+ (if test-id
+ (list (db:test-get-run_id test-data)
+ target
+ runname
+ "n/a")
+ (make-list 4 "")))
+ (list test-info-matrix
+ (if test-id
+ (list test-id
+ (db:test-get-testname test-data)
+ (db:test-get-item-path test-data)
+ (db:test-get-state test-data)
+ (db:test-get-status test-data)
+ (seconds->string (db:test-get-event_time test-data))
+ (db:test-get-comment test-data))
+ (make-list 7 "")))
+ (list test-run-matrix
+ (if test-id
+ (list (db:test-get-host test-data)
+ (db:test-get-uname test-data)
+ (db:test-get-diskfree test-data)
+ (db:test-get-cpuload test-data)
+ (seconds->hr-min-sec (db:test-get-run_duration test-data)))
+ (make-list 5 "")))
+ ))
+ (dcommon:populate-steps steps-dat steps-matrix))))))
+ ;;(list meta-dat-matrix
+ ;; (if test-id
+ ;; (list (
+
+
+;; db:test-get-id
+;; db:test-get-run_id
+;; db:test-get-testname
+;; db:test-get-state
+;; db:test-get-status
+;; db:test-get-event_time
+;; db:test-get-host
+;; db:test-get-cpuload
+;; db:test-get-diskfree
+;; db:test-get-uname
+;; db:test-get-rundir
+;; db:test-get-item-path
+;; db:test-get-run_duration
+;; db:test-get-final_logf
+;; db:test-get-comment
+;; db:test-get-fullname
+
+
+;;======================================================================
+;; R U N C O N T R O L
+;;======================================================================
+
+;; Overall runs browser
+;;
+(define (runs window-id)
+ (let* ((runs-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:fittosize "YES"
+ #:scrollbar "YES"
+ #:numcol 100
+ #:numlin 100
+ #:numcol-visible 7
+ #:numlin-visible 7
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+
+ (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
+ (iup:attribute-set! runs-matrix "WIDTH0" "100")
+
+ (dboard:data-set-runs-matrix! *data* runs-matrix)
+ (iup:hbox
+ (iup:frame
+ #:title "Runs browser"
+ (iup:vbox
+ runs-matrix)))))
+
+;; Browse and control a single run
+;;
+(define (runcontrol window-id)
+ (iup:hbox))
+
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+;; Main Panel
+(define (main-panel window-id)
+ (iup:dialog
+ #:title "Megatest Control Panel"
+ #:menu (dcommon:main-menu)
+ #:shrink "YES"
+ (let ((tabtop (iup:tabs
+ (runs window-id)
+ (tests window-id)
+ (runcontrol window-id)
+ (mtest window-id)
+ (rconfig window-id)
+ )))
+ (iup:attribute-set! tabtop "TABTITLE0" "Runs")
+ (iup:attribute-set! tabtop "TABTITLE1" "Tests")
+ (iup:attribute-set! tabtop "TABTITLE2" "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-set-runs! *data* data) ;; make this data available to the rest of the application
+ (iup:show (main-panel my-window-id))
+ ;; 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
+ (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 "CHANGE(S): " (car changes) "..."))
+ (debug:print-info 11 "Server overloaded"))))))
+
+(dboard:data-set-updaters! *data* (make-hash-table))
+(newdashboard *dbstruct-local*)
+(iup:main-loop)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -1661,24 +1661,32 @@
(exit 3))
((not runname)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
(exit 3))
(else
- (let (;; (db #f)
- (keys #f))
- (if (launch:setup-for-run)
- (launch:cache-config)
+ (let* ((keys #f)
+ (testsuite-data (common:multi-setup-for-run))
+ (configdat (common_records:testsuite-get-configdat testsuite-data))
+ (toppath (common_records:testsuite-get-toppath testsuite-data)))
+ (if testsuite-data
+ (common:with-vars
+ testsuite-data
+ (lambda ()
+ (launch:cache-config testsuite-data)))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; (if (args:get-arg "-server")
;; (cdb:remote-run server:start db (args:get-arg "-server")))
- (set! keys (keys:config-get-fields *configdat*))
+ (set! keys (keys:config-get-fields configdat))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
- (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
- (runconfig (read-config runconfigf #f #t environ-patt: #f)))
+ (let* ((runconfigf (conc toppath "/runconfigs.config")) ;; DO NOT EVALUATE ALL
+ (runconfig (common:with-vars
+ testsuite-data
+ (lambda ()
+ (read-config runconfigf #f #t environ-patt: #f)))))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
(begin
(debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
@@ -1685,19 +1693,18 @@
;; (if db (sqlite3:finalize! db))
(exit 1)
)))
(if (args:get-arg "-target")
(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
- (if (not (car *configinfo*))
+ (if testsuite-data ;; (not (car *configinfo*))
(begin
(debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
(exit 1))
;; Extract out stuff needed in most or many calls
;; here then call proc
(let* ((keyvals (keys:target->keyval keys target)))
(proc target runname keys keyvals)))
- ;; (if db (sqlite3:finalize! db))
(set! *didsomething* #t))))))
;;======================================================================
;; Lock/unlock runs
;;======================================================================