Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -43,14 +43,18 @@
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
(define *db-keys* #f)
-(define *configinfo* #f)
-(define *configdat* #f)
-(define *toppath* #f)
+
+(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
+(define *runconfigdat* #f) ;; run configs data
+(define *configdat* #f) ;; megatest.config data
+(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
+(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))
@@ -447,36 +451,42 @@
rtestpatt)
args-testpatt)))
(if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt))
testpatt))
+(define (common:get-linktree)
+ (or (getenv "MT_LINKTREE")
+ (if *configdat*
+ (configf:lookup *configdat* "setup" "linktree"))))
+
(define (common:args-get-runname)
- (or (args:get-arg "-runname")
- (args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
+ (let ((res (or (args:get-arg "-runname")
+ (args:get-arg ":runname")
+ (getenv "MT_RUNNAME"))))
+ ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
+ res))
(define (common:args-get-target #!key (split #f))
- (let* ((keys (keys:config-get-fields *configdat*))
+ (let* ((keys (if *configdat* (keys:config-get-fields *configdat*) '()))
(numkeys (length keys))
- (target (if (args:get-arg "-reqtarg")
- (args:get-arg "-reqtarg")
- (if (args:get-arg "-target")
- (args:get-arg "-target")
- (getenv "MT_TARGET"))))
+ (target (or (args:get-arg "-reqtarg")
+ (args:get-arg "-target")
+ (getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
- (and (not (null? tlist))
- (eq? numkeys (length tlist))
- (null? (filter string-null? tlist)))
+ (or (null? keys) ;; probably don't know our keys yet
+ (and (not (null? tlist))
+ (eq? numkeys (length tlist))
+ (null? (filter string-null? tlist))))
#f)))
(if valid
(if split
tlist
target)
(if target
(begin
- (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/"))
+ (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
#f)
#f))))
;;======================================================================
;; M I S C L I S T S
@@ -709,11 +719,16 @@
;; E N V I R O N M E N T V A R S
;;======================================================================
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES")))
(let ((envvars (get-environment-variables))
- (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")))
+ (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))
+ (mungeval (lambda (val)
+ (cond
+ ((eq? val #t) "") ;; convert #t to empty string
+ ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one
+ (else val)))))
(with-output-to-file (conc fname ".csh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
@@ -721,11 +736,11 @@
"\""
"")))
(print (if (member key ignorevars)
"# setenv "
"setenv ")
- key " " delim val delim)))
+ key " " delim (mungeval val) delim)))
envvars)))
(with-output-to-file (conc fname ".sh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
@@ -734,11 +749,11 @@
"\""
"")))
(print (if (member key ignorevars)
"# export "
"export ")
- key "=" delim val delim)))
+ key "=" delim (mungeval val) delim)))
envvars)))))
;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
(define (alist->env-vars lst)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -99,10 +99,12 @@
;; (print "fullcmd=" fullcmd)
(handle-exceptions
exn
(begin
(debug:print 0 "WARNING: failed to process config input \"" l "\"")
+ (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print "exn=" (condition->list exn))
(set! result (conc "#{( " cmdtype ") " cmd"}")))
(if (or allow-system
(not (member cmdtype '("system" "shell"))))
(with-input-from-string fullcmd
(lambda ()
@@ -159,11 +161,18 @@
(configf:process-line inl ht allow-processing)))))
(if (and (string? res)
(not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
(string-substitute "\\s+$" "" res)
res))))))
-
+
+(define (calc-allow-system allow-system section sections)
+ (if sections
+ (and (or (equal? "default" section)
+ (member section sections))
+ allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
+ allow-system))
+
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
@@ -182,11 +191,11 @@
(let ((inp (open-input-file path))
(res (if (not ht)(make-hash-table) ht))
(metapath (if (or (debug:debug-mode 9)
keep-filenames)
path #f)))
- (let loop ((inl (configf:read-line inp res allow-system settings)) ;; (read-line inp))
+ (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
(curr-section-name (if curr-section curr-section "default"))
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
(debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
(if (eof-object? inl)
@@ -195,15 +204,15 @@
(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
(debug:print 9 "END: " path)
res)
(regex-case
inl
- (configf:comment-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
- (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
+ (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(configf:settings ( x setting val ) (begin
(hash-table-set! settings setting val)
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
(configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (absolute-pathname? include-file)
include-file
(nice-path
(conc (if curr-conf-dir
@@ -214,31 +223,31 @@
(begin
;; (push-directory conf-dir)
(debug:print 9 "Including: " full-conf)
(read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
;; (pop-directory)
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")")
(debug:print 2 " " full-conf)
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
(configf:section-rx ( x section-name ) (begin
;; call post-section-procs
(for-each
(lambda (dat)
(let ((patt (car dat))
(proc (cdr dat)))
(if (string-match patt curr-section-name)
(proc curr-section-name section-name res path))))
post-section-procs)
- (loop (configf:read-line inp res allow-system settings)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
;; if we have the sections list then force all settings into "" and delete it later?
(if (or (not sections)
(member section-name sections))
section-name "") ;; stick everything into ""
#f #f)))
- (configf:key-sys-pr ( x key cmd ) (if allow-system
+ (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections)
(let ((alist (hash-table-ref/default res curr-section-name '()))
(val-proc (lambda ()
(let* ((start-time (current-seconds))
(cmdres (process:cmd-run->list cmd))
(delta (- (current-seconds) start-time))
@@ -256,17 +265,24 @@
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
key
- (case allow-system
+ (case (calc-allow-system allow-system curr-section-name sections)
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))
metadata: metapath))
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+ (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+ (debug:print 10 " setting: [" curr-section-name "] " key " = #t")
+ (safe-setenv key fval)
+ (hash-table-set! res curr-section-name
+ (config:assoc-safe-add alist key fval metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
(configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '()))
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
@@ -273,16 +289,11 @@
(debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
(if envar (safe-setenv key realval))
(debug:print 10 " setting: [" curr-section-name "] " key " = " val)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval metadata: metapath))
- (loop (configf:read-line inp res allow-system settings) curr-section-name key #f)))
- (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())))
- (debug:print 10 " setting: [" curr-section-name "] " key " = #t")
- (hash-table-set! res curr-section-name
- (config:assoc-safe-add alist key #t metadata: metapath))
- (loop (configf:read-line inp res allow-system settings) curr-section-name key #f)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
;; if a continued line
(configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
(config-lookup res curr-section-name var-flag) "\n"
@@ -292,15 +303,15 @@
"")
val)))
;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist var-flag newval metadata: metapath))
- (loop (configf:read-line inp res allow-system settings) curr-section-name var-flag (if lead lead whsp)))
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
- (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))))))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))))))
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -235,11 +235,11 @@
;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
(let* ((subarea (configf:lookup testconfig "setup" "submegatest"))
(area-exists (and subarea (file-exists? subarea))))
- (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists)
+ ;; (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists)
(if subarea
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:button
"Launch Dashboard"
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -14,11 +14,11 @@
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct sparse-vectors)
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
@@ -81,72 +81,189 @@
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
-(if (not (launch:setup-for-run))
+(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
-(define *useserver* (cond
- ((args:get-arg "-use-local") #f)
- ((configf:lookup *configdat* "dashboard" "use-server")
- (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
- (if (equal? ans "yes") #t #f)))
- (else #t)))
-
-(define *dbdir* (db:dbfile-path #f)) ;; (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))
+;; create a stuct for all the miscellaneous state
+;;
+(defstruct d:alldat
+ allruns
+ allruns-by-id
+ buttondat
+ curr-tab-num
+ dbdir
+ dbfpath
+ dbkeys
+ dblocal
+ header
+ hide-empty-runs
+ hide-not-hide ;; toggle for hide/not hide
+ hide-not-hide-button
+ hide-not-hide-tabs
+ item-test-names
+ keys
+ last-db-update
+ num-tests
+ numruns
+ please-update
+ ro
+ searchpatts
+ start-run-offset
+ start-test-offset
+ state-ignore-hash
+ status-ignore-hash
+ tot-runs
+ update-mutex
+ updaters
+ updating
+ useserver
+ )
+
+(define *alldat* (make-d:alldat
+ header: #f
+ allruns: '()
+ allruns-by-id: (make-hash-table)
+ buttondat: (make-hash-table)
+ searchpatts: (make-hash-table)
+ numruns: 16
+ last-db-update: 0
+ please-update: #t
+ updating: #f
+ update-mutex: (make-mutex)
+ item-test-names: '()
+ num-tests: 15
+ start-run-offset: 0
+ start-test-offset: 0
+ status-ignore-hash: (make-hash-table)
+ state-ignore-hash: (make-hash-table)
+ hide-empty-runs: #f
+ hide-not-hide: #t
+ hide-not-hide-button: #f
+ hide-not-hide-tabs: #f
+ curr-tab-num: 0
+ updaters: (make-hash-table)
+ ))
+
+;; simple two dimentional sparse array
+;;
+(define (make-sparse-array)
+ (let ((a (make-sparse-vector)))
+ (sparse-vector-set! a 0 (make-sparse-vector))
+ a))
+
+(define (sparse-array? a)
+ (and (sparse-vector? a)
+ (sparse-vector? (sparse-vector-ref a 0))))
+
+(define (sparse-array-ref a x y)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-ref row y)
+ #f)))
+
+(define (sparse-array-set! a x y val)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-set! row y val)
+ (let ((new-row (make-sparse-vector)))
+ (sparse-vector-set! a x new-row)
+ (sparse-vector-set! new-row y val)))))
+
+;; data for runs, tests etc
+;;
+(defstruct d:rundat
+ ;; new system
+ runs-index ;; target/runname => colnum
+ tests-index ;; testname/itempath => rownum
+ matrix-dat ;; vector of vectors rows/cols
+ )
+
+(define (d:rundat-make-init)
+ (make-d:rundat
+ runs-index: (make-hash-table)
+ tests-index: (make-hash-table)
+ matrix-dat: (make-sparse-array)))
+
+(defstruct d:testdat
+ id ;; testid
+ state ;; test state
+ status ;; test status
+ )
+
+(define (d:rundat-get-col-num dat target runname force-set)
+ (let* ((runs-index (d:rundat-runs-index dat))
+ (col-name (conc target "/" runname))
+ (res (hash-table-ref/default runs-index col-name #f)))
+ (if res
+ res
+ (if force-set
+ (let ((max-col-num (+ 1 (apply max -1 (hash-table-values runs-index)))))
+ (hash-table-set! runs-index col-name max-col-num)
+ max-col-num)))))
+
+(define (d:rundat-get-row-num dat testname itempath force-set)
+ (let* ((tests-index (d:rundat-runs-index dat))
+ (row-name (conc testname "/" itempath))
+ (res (hash-table-ref/default runs-index row-name #f)))
+ (if res
+ res
+ (if force-set
+ (let ((max-row-num (+ 1 (apply max -1 (hash-table-values tests-index)))))
+ (hash-table-set! runs-index row-name max-row-num)
+ max-row-num)))))
+
+;; default is to NOT set the cell if the column and row names are not pre-existing
+;;
+(define (d:rundat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
+ (let* ((col-num (d:rundat-get-col-num dat target runname force-set))
+ (row-num (d:rundat-get-row-num dat testname itempath force-set)))
+ (if (and row-num col-num)
+ (let ((tdat (d:testdat
+ id: test-id
+ state: state
+ status: status)))
+ (sparse-array-set! (d:rundat-matrix-dat dat) col-num row-num tdat)
+ tdat)
+ #f)))
+
+
+
+
+
+(d:alldat-useserver-set! *alldat* (cond
+ ((args:get-arg "-use-local") #f)
+ ((configf:lookup *configdat* "dashboard" "use-server")
+ (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
+ (if (equal? ans "yes") #t #f)))
+ (else #t)))
+
+(d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+(d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path: (d:alldat-dbdir *alldat*)
+ local: #t))
+(d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0))
;; HACK ALERT: this is a hack, please fix.
-(define *read-only* (not (file-read-access? *db-file-path*)))
-
-(define toplevel #f)
-(define dlg #f)
-(define max-test-num 0)
-(define *keys* (if *useserver*
- (rmt:get-keys)
- (db:get-keys *dbstruct-local*)))
-
-(define *dbkeys* (append *keys* (list "runname")))
-
-(define *header* #f)
-(define *allruns* '())
-(define *allruns-by-id* (make-hash-table)) ;;
-(define *runchangerate* (make-hash-table))
-
-(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
-(define *alltestnamelst* '())
-(define *searchpatts* (make-hash-table))
-(define *num-runs* 8)
-(define *tot-run-count* (if *useserver*
- (rmt:get-num-runs "%")
- (db:get-num-runs *dbstruct-local* "%")))
-
-;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
-
-;; Update management
-;;
-(define *last-update* (current-seconds))
-(define *last-db-update-time* 0)
-(define *please-update-buttons* #t)
-(define *delayed-update* 0)
-(define *update-is-running* #f)
-(define *update-mutex* (make-mutex))
-
-(define *all-item-test-names* '())
-(define *num-tests* 15)
-(define *start-run-offset* 0)
-(define *start-test-offset* 0)
-(define *examine-test-dat* (make-hash-table))
+(d:alldat-ro-set! *alldat* (not (file-read-access? (d:alldat-dbfpath *alldat*))))
+
+(d:alldat-keys-set! *alldat* (if (d:alldat-useserver *alldat*)
+ (rmt:get-keys)
+ (db:get-keys (d:alldat-dblocal *alldat*))))
+(d:alldat-dbkeys-set! *alldat* (append (d:alldat-keys *alldat*) (list "runname")))
+(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*)
+ (rmt:get-num-runs "%")
+ (db:get-num-runs (d:alldat-dblocal *alldat*) "%")))
+;;
(define *exit-started* #f)
-(define *status-ignore-hash* (make-hash-table))
-(define *state-ignore-hash* (make-hash-table))
+;; *updaters* (make-hash-table))
+;; sorting global data (would apply to many testsuites so leave it global for now)
+;;
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
(vector "Sort +t" 'event_time "ASC")
(vector "Sort -t" 'event_time "DESC")
(vector "Sort +s" 'statestatus "ASC")
@@ -174,18 +291,10 @@
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
-(define *hide-empty-runs* #f)
-(define *hide-not-hide* #t) ;; toggle for hide/not hide
-(define *hide-not-hide-button* #f)
-(define *hide-not-hide-tabs* #f)
-
-(define *current-tab-number* 0)
-(define *updaters* (make-hash-table))
-
(debug:setup)
(define uidat #f)
(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
@@ -243,20 +352,20 @@
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
(let* ((referenced-run-ids '())
- (allruns (if *useserver*
- (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
- (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
- *start-run-offset* keypatts)))
+ (allruns (if (d:alldat-useserver *alldat*)
+ (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts)
+ (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
+ (d:alldat-start-run-offset *alldat*) keypatts)))
(header (db:get-header allruns))
(runs (db:get-rows allruns))
(result '())
(maxtests 0)
- (states (hash-table-keys *state-ignore-hash*))
- (statuses (hash-table-keys *status-ignore-hash*))
+ (states (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))
+ (statuses (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
@@ -264,28 +373,28 @@
;;
;; trim runs to only those that are changing often here
;;
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
- (key-vals (if *useserver*
+ (key-vals (if (d:alldat-useserver *alldat*)
(rmt:get-key-vals run-id)
- (db:get-key-vals *dbstruct-local* run-id)))
- (prev-dat (let ((rec (hash-table-ref/default *allruns-by-id* run-id #f)))
+ (db:get-key-vals (d:alldat-dblocal *alldat*) run-id)))
+ (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f)))
(if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
(prev-tests (vector-ref prev-dat 1))
(last-update (vector-ref prev-dat 3))
- (tmptests (if *useserver*
+ (tmptests (if (d:alldat-useserver *alldat*)
(rmt:get-tests-for-run run-id testnamepatt states statuses
#f #f
- *hide-not-hide*
+ (d:alldat-hide-not-hide *alldat*)
sort-by
sort-order
'shortlist
last-update)
- (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
+ (db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses
#f #f
- *hide-not-hide*
+ (d:alldat-hide-not-hide *alldat*)
sort-by
sort-order
'shortlist
last-update)))
(tests (let ((newdat (filter
@@ -295,32 +404,28 @@
(lambda (a b)
(eq? (db:test-get-id a)(db:test-get-id b)))))))
(if (eq? *tests-sort-reverse* 3) ;; +event_time
(sort newdat compare-tests)
newdat))))
- ;; NOTE: bubble-up also sets the global *all-item-test-names*
+ ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*)
;; (tests (bubble-up tmptests priority: bubble-type))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
- (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
+ (if (or (not (d:alldat-hide-empty-runs *alldat*)) ;; this reduces the data burden when set
(not (null? tests)))
(let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
- ;;
- ;; compare the tests with the tests in *allruns-by-id* same run-id
- ;; if different then increment value in *runchangerate*
- ;;
- (hash-table-set! *allruns-by-id* run-id dstruct)
+ (hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct)
(set! result (cons dstruct result))))))
runs)
- (set! *header* header)
- (set! *allruns* result)
- (debug:print-info 6 "*allruns* has " (length *allruns*) " runs")
+ (d:alldat-header-set! *alldat* header)
+ (d:alldat-allruns-set! *alldat* result)
+ (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs")
maxtests))
(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
@@ -444,30 +549,30 @@
(hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '())))
;; This is item, append it
(hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat))))))
test-dats)
;; Set all tests with items
- (set! *all-item-test-names* (append (if (null? tnames)
- '()
- (filter (lambda (tname)
- (let ((tlst (hash-table-ref tests tname)))
- (and (list tlst)
- (> (length tlst) 1))))
- tnames))
- *all-item-test-names*))
+ (d:alldat-item-test-names-set! *alldat* (append (if (null? tnames)
+ '()
+ (filter (lambda (tname)
+ (let ((tlst (hash-table-ref tests tname)))
+ (and (list tlst)
+ (> (length tlst) 1))))
+ tnames))
+ (d:alldat-item-test-names *alldat*)))
(let loop ((hed (car tnames))
(tal (cdr tnames))
(res '()))
(let ((newres (append res (hash-table-ref tests hed))))
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres))))))))
(define (update-buttons uidat numruns numtests)
- (let* ((runs (if (> (length *allruns*) numruns)
- (take-right *allruns* numruns)
- (pad-list *allruns* numruns)))
+ (let* ((runs (if (> (length (d:alldat-allruns *alldat*)) numruns)
+ (take-right (d:alldat-allruns *alldat*) numruns)
+ (pad-list (d:alldat-allruns *alldat*) numruns)))
(lftcol (dboard:uidat-get-lftcol uidat))
(tableheader (dboard:uidat-get-header uidat))
(table (dboard:uidat-get-runsvec uidat))
(coln 0))
(set! *alltestnamelst* '())
@@ -475,36 +580,36 @@
(for-each
(lambda (rundat)
(if (vector? rundat)
(let* ((testdat (vector-ref rundat 1))
(testnames (map test:test-get-fullname testdat)))
- (if (not (and *hide-empty-runs*
+ (if (not (and (d:alldat-hide-empty-runs *alldat*)
(null? testnames)))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames)))))
runs)
(set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
- (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
- (drop *alltestnamelst* *start-test-offset*)
+ (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (d:alldat-start-test-offset *alldat*))
+ (drop *alltestnamelst* (d:alldat-start-test-offset *alldat*))
'())))
- (append xl (make-list (- *num-tests* (length xl)) ""))))
+ (append xl (make-list (- (d:alldat-num-tests *alldat*) (length xl)) ""))))
(update-labels uidat)
(for-each
(lambda (rundat)
(if (not rundat) ;; handle padded runs
;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
- (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3)))
+ (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") (d:alldat-keys *alldat*)))));; 3)))
(let* ((run (vector-ref rundat 0))
(testsdat (vector-ref rundat 1))
(key-val-dat (vector-ref rundat 2))
- (run-id (db:get-value-by-header run *header* "id"))
+ (run-id (db:get-value-by-header run (d:alldat-header *alldat*) "id"))
(key-vals (append key-val-dat
- (list (let ((x (db:get-value-by-header run *header* "runname")))
+ (list (let ((x (db:get-value-by-header run (d:alldat-header *alldat*) "runname")))
(if x x "")))))
(run-key (string-intersperse key-vals "\n")))
;; fill in the run header key values
(let ((rown 0)
@@ -519,11 +624,11 @@
;; For this run now fill in the buttons for each test
(let ((rown 0)
(columndat (vector-ref table coln)))
(for-each
(lambda (testname)
- (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f)))
+ (let ((buttondat (hash-table-ref/default (d:alldat-buttondat *alldat*) (mkstr coln rown) #f)))
(if buttondat
(let* ((test (let ((matching (filter
(lambda (x)(equal? (test:test-get-fullname x) testname))
testsdat)))
(if (null? matching)
@@ -564,29 +669,28 @@
(define (mkstr . x)
(string-intersperse (map conc x) ","))
(define (set-bg-on-filter)
(let ((search-changed (not (null? (filter (lambda (key)
- (not (equal? (hash-table-ref *searchpatts* key) "%")))
- (hash-table-keys *searchpatts*)))))
- (state-changed (not (null? (hash-table-keys *state-ignore-hash*))))
- (status-changed (not (null? (hash-table-keys *status-ignore-hash*)))))
- (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR"
+ (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%")))
+ (hash-table-keys (d:alldat-searchpatts *alldat*))))))
+ (state-changed (not (null? (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))))
+ (status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*))))))
+ (iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR"
(if (or search-changed
state-changed
status-changed)
"190 180 190"
"190 190 190"
))))
(define (update-search x val)
- (hash-table-set! *searchpatts* x val)
+ (hash-table-set! (d:alldat-searchpatts *alldat*) x val)
(set-bg-on-filter))
(define (mark-for-update)
- (set! *last-db-update-time* 0)
- (set! *delayed-update* 1))
+ (d:alldat-last-db-update-set! *alldat* 0))
;;======================================================================
;; R U N C O N T R O L
;;======================================================================
@@ -632,13 +736,13 @@
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
- (db-target-dat (if *useserver*
+ (db-target-dat (if (d:alldat-useserver *alldat*)
(rmt:get-targets)
- (db:get-targets *dbstruct-local*)))
+ (db:get-targets (d:alldat-dblocal *alldat*))))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(all-targets (append db-targets
(map (lambda (x)
(list->vector
@@ -757,11 +861,11 @@
;; (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 'dotscale 60)
+ (hash-table-set! tests-draw-state 'dotscale 10.5)
(hash-table-set! tests-draw-state 'tests-info (make-hash-table))
(hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
;; set these
(hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
(hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
@@ -799,11 +903,11 @@
;; (hash-table-set! tests-draw-state 'scalef 1)
;; (hash-table-set! tests-draw-state 'dotscale 60)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
- ;; refer to *keys*, *dbkeys* for keys
+ ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys
(iup:vbox
;; The command line display/exectution control
(iup:frame
#:title "Command to be exectuted"
(iup:hbox
@@ -868,13 +972,13 @@
(iup:attribute-set! tb "VALUE" val)
(dboard:data-set-run-name! *data* val)
(dashboard:update-run-command))))
(refresh-runs-list (lambda ()
(let* ((target (dboard:data-get-target-string *data*))
- (runs-for-targ (if *useserver*
- (rmt:get-runs-by-patt *keys* "%" target #f #f #f)
- (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)))
+ (runs-for-targ (if (d:alldat-useserver *alldat*)
+ (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f)
+ (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f)))
(runs-header (vector-ref runs-for-targ 0))
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
@@ -1089,32 +1193,207 @@
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
-(define (tree-path->run-id path)
+(define (tree-path->run-id data path)
(if (not (null? path))
- (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f)
+ (hash-table-ref/default (d:data-path-run-ids data) path #f)
#f))
(define dashboard:update-run-summary-tab #f)
-;; (define (tests window-id)
-(define (dashboard:one-run db)
+;; This is the Run Summary tab
+;;
+(define (dashboard:one-run db data)
+ (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 data (cdr run-path))))
+ (if (number? run-id)
+ (begin
+ (d:data-curr-run-id-set! data run-id)
+ (dashboard:update-run-summary-tab))
+ (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id)))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
+ (cell-lookup (make-hash-table))
+ (run-matrix (iup:matrix
+ #:expand "YES"
+ #:click-cb
+ (lambda (obj lin col status)
+ (let* ((toolpath (car (argv)))
+ (key (conc lin ":" col))
+ (test-id (hash-table-ref/default cell-lookup key -1))
+ (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&")))
+ (system cmd)))))
+ (updater (lambda ()
+ (let* ((runs-dat (if (d:alldat-useserver *alldat*)
+ (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
+ (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (run-id (d:data-curr-run-id data))
+ (last-update 0) ;; fix me
+ (tests-dat (let ((tdat (if run-id
+ (if (d:alldat-useserver *alldat*)
+ (rmt:get-tests-for-run run-id
+ (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
+ (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
+ (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
+ #f #f
+ (d:alldat-hide-not-hide *alldat*)
+ #f #f
+ "id,testname,item_path,state,status"
+ last-update) ;; get 'em all
+ (db:get-tests-for-run db run-id
+ (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
+ (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
+ (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
+ #f #f
+ (d:alldat-hide-not-hide *alldat*)
+ #f #f
+ "id,testname,item_path,state,status"
+ last-update))
+ '()))) ;; get 'em all
+ (sort tdat (lambda (a b)
+ (let* ((aval (vector-ref a 2))
+ (bval (vector-ref b 2))
+ (anum (string->number aval))
+ (bnum (string->number bval)))
+ (if (and anum bnum)
+ (< anum bnum)
+ (string<= aval bval)))))))
+ (tests-mindat (dcommon:minimize-test-data tests-dat))
+ (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell))
+ (row-indices (cadr indices))
+ (col-indices (car indices))
+ (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
+ (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
+ (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window
+ (numrows 1)
+ (numcols 1)
+ (changed #f)
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
+ (vector-ref runs-dat 1))
+ ht))
+ (run-ids (sort (filter number? (hash-table-keys runs-hash))
+ (lambda (a b)
+ (let* ((record-a (hash-table-ref runs-hash a))
+ (record-b (hash-table-ref runs-hash b))
+ (time-a (db:get-value-by-header record-a runs-header "event_time"))
+ (time-b (db:get-value-by-header record-b runs-header "event_time")))
+ (< time-a time-b))))))
+
+ ;; (iup:attribute-set! tb "VALUE" "0")
+ ;; (iup:attribute-set! tb "NAME" "Runs")
+ ;; Update the runs tree
+ (for-each (lambda (run-id)
+ (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
+ (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
+ (d:alldat-keys *alldat*)))
+ (run-name (db:get-value-by-header run-record runs-header "runname"))
+ (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
+ (run-path (append key-vals (list run-name)))
+ (existing (tree:find-node tb run-path)))
+ (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f))
+ (begin
+ (hash-table-set! (d:data-run-keys data) run-id run-path)
+ ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
+ ;; (conc rownum ":" colnum) col-name)
+ ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
+ ;; Here we update the tests treebox and tree keys
+ (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
+ userdata: (conc "run-id: " run-id))
+ (hash-table-set! (d:data-path-run-ids data) run-path run-id)
+ ;; (set! colnum (+ colnum 1))
+ ))))
+ run-ids)
+ (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
+ (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
+ (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")
+ (iup:attribute-set! run-matrix "NUMCOL" max-col )
+ (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
+ ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col)
+ ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
+
+ ;; Row labels
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc num ":0")))
+ (if (not (equal? (iup:attribute run-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key name)))))
+ row-indices)
+
+ ;; Cell contents
+ (for-each (lambda (entry)
+ (let* ((row-name (cadr entry))
+ (col-name (car entry))
+ (valuedat (caddr entry))
+ (test-id (list-ref valuedat 0))
+ (test-name row-name) ;; (list-ref valuedat 1))
+ (item-path col-name) ;; (list-ref valuedat 2))
+ (state (list-ref valuedat 1))
+ (status (list-ref valuedat 2))
+ (value (gutils:get-color-for-state-status state status))
+ (row-num (cadr (assoc row-name row-indices)))
+ (col-num (cadr (assoc col-name col-indices)))
+ (key (conc row-num ":" col-num)))
+ (hash-table-set! cell-lookup key test-id)
+ (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key (cadr value))
+ (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
+ tests-mindat)
+
+ ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
+
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc "0:" num)))
+ (if (not (equal? (iup:attribute run-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key name)
+ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))
+ col-indices)
+ (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
+
+ (set! dashboard:update-run-summary-tab updater)
+ (d:data-runs-tree-set! data tb)
+ (iup:split
+ tb
+ run-matrix)))
+
+;; This is the New View tab
+;;
+(define (dashboard:new-view db data)
(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))))
+ (run-id (tree-path->run-id data (cdr run-path))))
(if (number? run-id)
(begin
- (dboard:data-set-curr-run-id! *data* run-id)
+ (d:data-curr-run-id-set! data run-id)
(dashboard:update-run-summary-tab))
(debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id)))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(cell-lookup (make-hash-table))
@@ -1123,36 +1402,39 @@
#:click-cb
(lambda (obj lin col status)
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
- (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&")))
+ (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&")))
(system cmd)))))
(updater (lambda ()
- (let* ((runs-dat (if *useserver*
- (rmt:get-runs-by-patt *keys* "%" #f #f #f #f)
- (db:get-runs-by-patt db *keys* "%" #f #f #f #f)))
- (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (run-id (dboard:data-get-curr-run-id *data*))
- (tests-dat (let ((tdat (if run-id
- (if *useserver*
- (rmt:get-tests-for-run run-id
- (hash-table-ref/default *searchpatts* "test-name" "%/%")
- (hash-table-keys *state-ignore-hash*) ;; '()
- (hash-table-keys *status-ignore-hash*) ;; '()
- #f #f
- *hide-not-hide*
- #f #f
- "id,testname,item_path,state,status") ;; get 'em all
- (db:get-tests-for-run db run-id
- (hash-table-ref/default *searchpatts* "test-name" "%/%")
- (hash-table-keys *state-ignore-hash*) ;; '()
- (hash-table-keys *status-ignore-hash*) ;; '()
- #f #f
- *hide-not-hide*
- #f #f
- "id,testname,item_path,state,status"))
+ (let* ((runs-dat (if (d:alldat-useserver *alldat*)
+ (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
+ (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (run-id (d:data-curr-run-id data))
+ (last-update 0) ;; fix me
+ (tests-dat (let ((tdat (if run-id
+ (if (d:alldat-useserver *alldat*)
+ (rmt:get-tests-for-run run-id
+ (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
+ (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
+ (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
+ #f #f
+ (d:alldat-hide-not-hide *alldat*)
+ #f #f
+ "id,testname,item_path,state,status"
+ last-update) ;; get 'em all
+ (db:get-tests-for-run db run-id
+ (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
+ (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
+ (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
+ #f #f
+ (d:alldat-hide-not-hide *alldat*)
+ #f #f
+ "id,testname,item_path,state,status"
+ last-update))
'()))) ;; get 'em all
(sort tdat (lambda (a b)
(let* ((aval (vector-ref a 2))
(bval (vector-ref b 2))
(anum (string->number aval))
@@ -1164,11 +1446,11 @@
(indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell))
(row-indices (cadr indices))
(col-indices (car indices))
(max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
(max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
- (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window
+ (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window
(numrows 1)
(numcols 1)
(changed #f)
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
@@ -1187,25 +1469,25 @@
;; (iup:attribute-set! tb "NAME" "Runs")
;; Update the runs tree
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
- *keys*))
+ (d:alldat-keys *alldat*)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name)))
(existing (tree:find-node tb run-path)))
- (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f))
+ (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f))
(begin
- (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path)
+ (hash-table-set! (d:data-run-keys data) run-id run-path)
;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
;; (conc rownum ":" colnum) col-name)
;; (hash-table-set! runid-to-col run-id (list colnum run-record))
;; Here we update the tests treebox and tree keys
(tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
- (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id)
+ (hash-table-set! (d:data-path-run-ids data) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids)
(iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
(iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
@@ -1261,20 +1543,20 @@
(iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))
col-indices)
(if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
(set! dashboard:update-run-summary-tab updater)
- (dboard:data-set-runs-tree! *data* tb)
+ (d:data-runs-tree-set! data tb)
(iup:split
tb
run-matrix)))
;;======================================================================
;; R U N S
;;======================================================================
-(define (make-dashboard-buttons db nruns ntests keynames)
+(define (make-dashboard-buttons db nruns ntests keynames runs-sum-dat new-view-dat)
(let* ((nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
@@ -1316,32 +1598,32 @@
;; (iup:button "Sort -t" #:action (lambda (obj)
;; (next-sort-option)
;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
;; (mark-for-update)))
(iup:button "HideEmpty" #:action (lambda (obj)
- (set! *hide-empty-runs* (not *hide-empty-runs*))
- (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE"))
+ (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*)))
+ (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE"))
(mark-for-update)))
(let ((hideit (iup:button "HideTests" #:action (lambda (obj)
- (set! *hide-not-hide* (not *hide-not-hide*))
- (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
+ (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*)))
+ (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide"))
(mark-for-update)))))
- (set! *hide-not-hide-button* hideit)
+ (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ...
hideit))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
- ;; (if *dbstruct-local* (db:close-all *dbstruct-local*))
+ ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*)))
(exit)))
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update)))
(iup:button "Collapse" #:action (lambda (obj)
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
(begin
(for-each (lambda (tname)
(hash-table-set! *collapsed* tname #t))
- *all-item-test-names*)
+ (d:alldat-item-test-names *alldat*))
(iup:attribute-set! obj "TITLE" "Expand"))
(begin
(for-each (lambda (tname)
(hash-table-delete! *collapsed* tname))
(hash-table-keys *collapsed*))
@@ -1354,38 +1636,38 @@
iup:hbox
(map (lambda (status)
(iup:toggle status #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
- (hash-table-set! *status-ignore-hash* status #t)
- (hash-table-delete! *status-ignore-hash* status))
+ (hash-table-set! (d:alldat-status-ignore-hash *alldat*) status #t)
+ (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) status))
(set-bg-on-filter))))
(map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(apply
iup:hbox
(map (lambda (state)
(iup:toggle state #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
- (hash-table-set! *state-ignore-hash* state #t)
- (hash-table-delete! *state-ignore-hash* state))
+ (hash-table-set! (d:alldat-state-ignore-hash *alldat*) state #t)
+ (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) state))
(set-bg-on-filter))))
(map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
(oldmax (string->number (iup:attribute obj "MAX")))
- (maxruns *tot-run-count*))
- (set! *start-run-offset* val)
+ (maxruns (d:alldat-tot-runs *alldat*)))
+ (d:alldat-start-run-offset-set! *alldat* val)
(mark-for-update)
- (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
+ (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
- #:max (* 10 (length *allruns*))
+ #:max (* 10 (length (d:alldat-allruns *alldat*)))
#:min 0
#:step 0.01)))
- ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1))))
- ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0))))
+ ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1))))
+ ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0))))
)
)
;; create the left most column for the run key names and the test names
(set! lftlst (list (iup:hbox
@@ -1409,13 +1691,13 @@
(set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (string->number (iup:attribute obj "VALUE")))
(oldmax (string->number (iup:attribute obj "MAX")))
(newmax (* 10 (length *alltestnamelst*))))
- (set! *please-update-buttons* #t)
- (set! *start-test-offset* (inexact->exact (round (/ val 10))))
- (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax)
+ (d:alldat-please-update-set! *alldat* #t)
+ (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10))))
+ (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax)
(if (< val 10)
(iup:attribute-set! obj "MAX" newmax))
))
#:expand "VERTICAL"
#:orientation "VERTICAL"
@@ -1468,17 +1750,17 @@
#:size "60x15"
#:expand "HORIZONTAL"
#:fontsize "10"
#:action (lambda (x)
(let* ((toolpath (car (argv)))
- (buttndat (hash-table-ref *buttondat* button-key))
+ (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(cmd (conc toolpath " -test " run-id "," test-id "&")))
;(print "Launching " cmd)
(system cmd))))))
- (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f))
+ (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
;; now assemble the hdrlst and bdylst and kick off the dialog
(iup:show
(iup:dialog
@@ -1491,60 +1773,64 @@
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))))))
controls))
+ (data (d:data-init (make-d:data)))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
- (set! *please-update-buttons* #t)
- (set! *current-tab-number* curr))
+ (d:alldat-please-update-set! *alldat* #t)
+ (d:alldat-curr-tab-num-set! *alldat* curr))
(dashboard:summary db)
runs-view
- (dashboard:one-run db)
+ (dashboard:one-run db runs-sum-dat)
+ (dashboard:new-view db new-view-dat)
(dashboard:run-controls)
)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
- (iup:attribute-set! tabs "TABTITLE3" "Run Control")
+ (iup:attribute-set! tabs "TABTITLE3" "New View")
+ (iup:attribute-set! tabs "TABTITLE4" "Run Control")
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
- (set! *hide-not-hide-tabs* tabs)
+ (d:alldat-hide-not-hide-tabs-set! *alldat* tabs)
tabs)))
(vector keycol lftcol header runsvec)))
(if (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS" ))
(begin
- (set! *num-tests* (string->number (or (args:get-arg "-rows")
- (get-environment-variable "DASHBOARDROWS"))))
- (update-rundat "%" *num-runs* "%/%" '()))
- (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20)))
+ (d:alldat-num-tests-set! *alldat* (string->number
+ (or (args:get-arg "-rows")
+ (get-environment-variable "DASHBOARDROWS"))))
+ (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()))
+ (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
-(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
+(d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
- (> (file-modification-time *db-file-path*) *last-db-update-time*))
+ (> (file-modification-time (d:alldat-dbfpath *alldat*)) (d:alldat-last-db-update *alldat*)))
(define (dashboard:set-db-update-time)
- (set! *last-db-update-time* (file-modification-time *db-file-path*)))
+ (d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))))
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
(> modtime last-db-update-time)
(> (current-seconds)(+ last-db-update-time 1)))))
-(define *monitor-db-path* (conc *dbdir* "/monitor.db"))
+(define *monitor-db-path* (conc (d:alldat-dbdir *alldat*) "/monitor.db"))
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(tasks:open-db)
@@ -1554,50 +1840,52 @@
(begin
(debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(apply max (map (lambda (filen)
(file-modification-time filen))
- (glob (conc *dbdir* "/*.db"))))))
+ (glob (conc (d:alldat-dbdir *alldat*) "/*.db"))))))
(define (dashboard:run-update x)
- (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
+ (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time (d:alldat-dbfpath *alldat*)))
(monitor-modtime (if (file-exists? *monitor-db-path*)
(file-modification-time *monitor-db-path*)
-1))
(run-update-time (current-seconds))
- (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
- (if (and (eq? *current-tab-number* 0)
+ (recalc (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*))))
+ (if (and (eq? (d:alldat-curr-tab-num *alldat*) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
(begin
(set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
(if dashboard:update-servers-table (dashboard:update-servers-table))))
(if recalc
(begin
- (case *current-tab-number*
+ (case (d:alldat-curr-tab-num *alldat*)
((0)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
((1) ;; The runs table is active
- (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
- (hash-table-ref/default *searchpatts* "test-name" "%/%")
- ;; (hash-table-ref/default *searchpatts* "item-name" "%")
+ (update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*)
+ (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
+ ;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
- (let ((val (hash-table-ref/default *searchpatts* key #f)))
+ (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f)))
(if val (set! res (cons (list key val) res))))))
- *dbkeys*)
+ (d:alldat-dbkeys *alldat*))
res))
- (update-buttons uidat *num-runs* *num-tests*))
+ (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*)))
((2)
+ (dashboard:update-run-summary-tab))
+ ((3)
(dashboard:update-run-summary-tab))
(else
- (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f)))
+ (let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*)
+ (d:alldat-curr-tab-num *alldat*) #f)))
(if updater (updater)))))
- (set! *please-update-buttons* #f)
- (set! *last-db-update-time* modtime)
- (set! *last-update* run-update-time)
+ (d:alldat-please-update-set! *alldat* #f)
+ (d:alldat-last-db-update-set! *alldat* modtime)
(set! *last-recalc-ended-time* (current-milliseconds))))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
@@ -1605,73 +1893,68 @@
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
-(cond
- ((args:get-arg "-run")
- (let ((runid (string->number (args:get-arg "-run"))))
- (if runid
- (begin
- (lambda (x)
- (on-exit std-exit-procedure)
- (examine-run *dbstruct-local* runid)))
- (begin
- (print "ERROR: runid is not a number " (args:get-arg "-run"))
- (exit 1)))))
- ((args:get-arg "-test") ;; run-id,test-id
- (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
- (if (> (length d) 1)
- d
- (list #f #f))))
- (run-id (car dat))
- (test-id (cadr dat)))
- (if (and (number? run-id)
- (number? test-id)
- (>= test-id 0))
- (examine-test run-id test-id)
- (begin
- (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
- (exit 1)))))
- ((args:get-arg "-guimonitor")
- (gui-monitor *dbstruct-local*))
- (else
- (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
- (iup:callback-set! *tim*
- "ACTION_CB"
- (lambda (x)
- (let ((update-is-running #f))
- (mutex-lock! *update-mutex*)
- (set! update-is-running *update-is-running*)
- (if (not update-is-running)
- (set! *update-is-running* #t))
- (mutex-unlock! *update-mutex*)
- (if (not update-is-running)
- (begin
- (dashboard:run-update x)
- (mutex-lock! *update-mutex*)
- (set! *update-is-running* #f)
- (mutex-unlock! *update-mutex*))))
- 1))))
-
-(let ((th1 (make-thread (lambda ()
- (thread-sleep! 1)
- (set! *please-update-buttons* #t)
- (dashboard:run-update 1)) "update buttons once"))
- ;; need to wait for first *update-is-running* #t
- ;; (let loop ()
- ;; (mutex-lock! *update-mutex*)
- ;; (if *update-is-running*
- ;; (begin
- ;; (set! *please-update-buttons* #t)
- ;; (mark-for-update)
- ;; (print "Did redraw trigger")) "First update after startup")
- ;; (mutex-unlock! *update-mutex*)
- ;; (thread-sleep! 1)
- ;; (if (not *please-update-buttons*)
- ;; (loop))))))
- (th2 (make-thread iup:main-loop "Main loop")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th2))
-
-;; (iup:main-loop)(db:close-all *dbstruct-local*)
+(define (main)
+ (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab
+ (new-view-dat (d:data-init (make-d:data))))
+ (cond
+ ((args:get-arg "-run")
+ (let ((runid (string->number (args:get-arg "-run"))))
+ (if runid
+ (begin
+ (lambda (x)
+ (on-exit std-exit-procedure)
+ (examine-run (d:alldat-dblocal *alldat*) runid)))
+ (begin
+ (print "ERROR: runid is not a number " (args:get-arg "-run"))
+ (exit 1)))))
+ ((args:get-arg "-test") ;; run-id,test-id
+ (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
+ (if (> (length d) 1)
+ d
+ (list #f #f))))
+ (run-id (car dat))
+ (test-id (cadr dat)))
+ (if (and (number? run-id)
+ (number? test-id)
+ (>= test-id 0))
+ (examine-test run-id test-id)
+ (begin
+ (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
+ (exit 1)))))
+ ((args:get-arg "-guimonitor")
+ (gui-monitor (d:alldat-dblocal *alldat*)))
+ (else
+ (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*)
+ (d:alldat-numruns *alldat*)
+ (d:alldat-num-tests *alldat*)
+ (d:alldat-dbkeys *alldat*)
+ runs-sum-dat new-view-dat))
+ (iup:callback-set! *tim*
+ "ACTION_CB"
+ (lambda (x)
+ (let ((update-is-running #f))
+ (mutex-lock! (d:alldat-update-mutex *alldat*))
+ (set! update-is-running (d:alldat-updating *alldat*))
+ (if (not update-is-running)
+ (d:alldat-updating-set! *alldat* #t))
+ (mutex-unlock! (d:alldat-update-mutex *alldat*))
+ (if (not update-is-running)
+ (begin
+ (dashboard:run-update x)
+ (mutex-lock! (d:alldat-update-mutex *alldat*))
+ (d:alldat-updating-set! *alldat* #f)
+ (mutex-unlock! (d:alldat-update-mutex *alldat*)))))
+ 1))))
+
+ (let ((th1 (make-thread (lambda ()
+ (thread-sleep! 1)
+ (d:alldat-please-update-set! *alldat* #t)
+ (dashboard:run-update 1)) "update buttons once"))
+ (th2 (make-thread iup:main-loop "Main loop")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th2))))
+
+(main)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -728,11 +728,11 @@
;; 'closeall - close all opened dbs
;;
;; run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
- (let* ((toppath (launch:setup-for-run))
+ (let* ((toppath (launch:setup))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
(mtdb (if toppath (db:open-megatest-db)))
(allow-cleanup (if run-ids #f #t))
(run-ids (if run-ids
run-ids
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -11,11 +11,11 @@
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
-(use regex)
+(use regex defstruct)
(declare (unit dcommon))
(declare (uses megatest-version))
(declare (uses gutils))
@@ -63,10 +63,15 @@
(define (dboard:data-get-target-string vec)
(let ((targ (dboard:data-get-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
(define (dboard:data-get-run-name vec) (vector-ref vec 19))
(define (dboard:data-get-runs-listbox vec) (vector-ref vec 20))
+
+(defstruct d:data runs tests runs-matrix tests-tree run-keys
+ curr-test-ids updaters path-run-ids curr-run-id runs-tree test-patts
+ states statuses logs-textbox command command-tb target run-name
+ runs-listbox)
(define (dboard:data-set-runs! vec val)(vector-set! vec 0 val))
(define (dboard:data-set-tests! vec val)(vector-set! vec 1 val))
(define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val))
(define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val))
@@ -98,10 +103,16 @@
;; Look up test-ids by (key1 key2 ... testname [itempath])
(dboard:data-set-path-test-ids! *data* (make-hash-table))
;; Look up run-ids by ??
(dboard:data-set-path-run-ids! *data* (make-hash-table))
+
+(define (d:data-init dat)
+ (d:data-run-keys-set! dat (make-hash-table))
+ (d:data-curr-test-ids-set! dat (make-hash-table))
+ (d:data-path-run-ids-set! dat (make-hash-table))
+ dat)
;;======================================================================
;; D O T F I L E
;;======================================================================
@@ -407,11 +418,11 @@
(row-indices (car indices))
(col-indices (cadr indices))
(max-row (if (null? row-indices) 1 (apply max (map cadr row-indices))))
(max-col (if (null? col-indices) 1
(apply max (map cadr col-indices))))
- (max-visible (max (- *num-tests* 15) 3))
+ (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3))
(max-col-vis (if (> max-col 10) 10 max-col))
(numrows 1)
(numcols 1))
(iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
(iup:attribute-set! stats-matrix "NUMCOL" max-col )
ADDED fsl-rebase.scm
Index: fsl-rebase.scm
==================================================================
--- /dev/null
+++ fsl-rebase.scm
@@ -0,0 +1,37 @@
+;; given branch and baseline commit generate list of commands to cherry pick commits
+;;
+;;
+;; Usage: fsl-rebase basecommit branch
+;;
+
+(use regex posix)
+
+(let* ((basecommit (cadr (argv)))
+ (branch (caddr (argv)))
+ (cmd (conc "fossil timeline after " basecommit " -n 1000000 -W 0"))
+ (theregex (conc ;; "^[^\\]]+"
+ "\\[([a-z0-9]+)\\]\\s+"
+ "(.*)"
+ "\\s+\\(.*tags:\\s+" branch
+ ;; ".*\\)"
+ )))
+ (print "basecommit: " basecommit ", branch: " branch ", theregex: " theregex ", cmd: \"" cmd "\"")
+ (with-input-from-pipe
+ cmd
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (not (eof-object? inl))
+ (let ((have-match (string-search theregex inl)))
+ (if have-match
+ (loop (read-line)
+ (cons (conc "fossil merge --cherrypick " (cadr have-match)
+ "\nfossil commit -m \"Cherry pick from " (cadr have-match)
+ ": " (caddr have-match) "\"")
+ res))
+ (loop (read-line) res)))
+ (map print res))))))
+
+;; (print "match: " inl "\n $1: " (cadr have-match) " $2: " (caddr have-match))
+;; (print "no match: " theregex " " inl))
+;; (loop (read-line))))))))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -138,15 +138,16 @@
(if logpro-used
(rmt:test-set-log! run-id test-id (conc stepname ".html")))
;; set the test final status
(let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
(this-step-status (cond
- ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings
- ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check
- ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = abort
- ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 4 = abort
- ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass
+ ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings
+ ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check
+ ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
+ ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort
+ ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip
+ ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass
(else 'fail)))
(overall-status (cond
((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
(else 'fail)))
@@ -158,12 +159,11 @@
(else 'fail)))
(next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
(cond
((null? tal) ;; more to run?
"COMPLETED")
- (else "RUNNING")))
- )
+ (else "RUNNING"))))
(debug:print 4 "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
(case next-status
((warn)
@@ -176,16 +176,28 @@
(launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
;; NB// test-set-status! does rdb calls under the hood
(tests:test-set-status! run-id test-id next-state "CHECK"
(if (eq? this-step-status 'check) "Logpro check found" #f)
#f))
+ ((waived)
+ (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "WAIVED"
+ (if (eq? this-step-status 'check) "Logpro waived found" #f)
+ #f))
((abort)
- (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 4) ;; rollup-status
+ (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
;; NB// test-set-status! does rdb calls under the hood
(tests:test-set-status! run-id test-id next-state "ABORT"
(if (eq? this-step-status 'abort) "Logpro abort found" #f)
#f))
+ ((skip)
+ (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
+ ;; NB// test-set-status! does rdb calls under the hood
+ (tests:test-set-status! run-id test-id next-state "SKIP"
+ (if (eq? this-step-status 'skip) "Logpro skip found" #f)
+ #f))
((pass)
(tests:test-set-status! run-id test-id next-state "PASS" #f #f))
(else ;; 'fail
(launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
(tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
@@ -269,15 +281,21 @@
;; (set-signal-handler! signal/int (lambda ()
;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
;;
- (let ((test-info (rmt:get-testinfo-state-status run-id test-id)))
+ (let* ((test-info (rmt:get-test-info-by-id run-id test-id))
+ (test-host (db:test-get-host test-info))
+ (test-pid (db:test-get-process_id test-info)))
(cond
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running
+ ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
+ (if (process:alive-on-host? test-host test-pid)
+ (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
+ (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
(debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
@@ -284,11 +302,11 @@
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
(set! keys (rmt:get-keys))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
- (if (not (launch:setup-for-run force: #t))
+ (if (not (launch:setup force: #t))
(begin
(debug:print 0 "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
@@ -437,22 +455,18 @@
(hash-table-ref/default testconfig "ezsteps" '())
#f)))
(if testconfig
(hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
(begin
- ;; got here but there are race condiitions - re-do all setup and try one more time
- (if (launch:setup-for-run)
- (begin
- (launch:cache-config)
- (set! testconfig (full-runconfigs-read))) ;; redunantly redundant, but does it resolve the race?
+ (launch:setup)
(debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n "
- (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))))
+ (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))
;; after all that, still no testconfig? Time to abort
(if (not testconfig)
(begin
(debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
- (exit 1)))s
+ (exit 1)))
(if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
;; if ezsteps was defined then we are sure to have at least one step but check anyway
(if (not (> (length ezstepslst) 0))
(debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
(let loop ((ezstep (car ezstepslst))
@@ -459,13 +473,14 @@
(tal (cdr ezstepslst))
(prevstep #f))
;; check exit-info (vector-ref exit-info 1)
(if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
(let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)))
- (if (and (steprun-good? logpro-used (launch:einf-exit-code exit-info))
- (not (null? tal)))
- (loop (car tal) (cdr tal) stepname)))
+ (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
+ (if (not (null? tal))
+ (loop (car tal) (cdr tal) stepname))
+ (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping")))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
(monitorjob (lambda ()
(let* ((start-seconds (current-seconds))
(calc-minutes (lambda ()
(inexact->exact
@@ -575,10 +590,14 @@
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3)
((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3)
;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
+ ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK")
+ ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED")
+ ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT")
+ ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP")
(else "FAIL")))) ;; (db:test-get-status testinfo)))
(debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info))
(tests:test-set-status! run-id
test-id
new-state
@@ -595,13 +614,47 @@
(mutex-unlock! m)
(debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(if (not (launch:einf-exit-status exit-info))
(exit 4)))))))
+
+(define (launch:cache-config)
+ ;; 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*
+ (or (args:get-arg "-run")
+ (args:get-arg "-runtests")
+ (args:get-arg "-execute")))
+ (let* ((linktree (get-environment-variable "MT_LINKTREE"))
+ (target (common:args-get-target))
+ (runname (or (args:get-arg "-runname")
+ (args:get-arg ":runname")
+ (getenv "MT_RUNNAME")))
+ (fulldir (conc linktree "/"
+ target "/"
+ runname)))
+ (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
+ (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree
+ (begin
+ (if (not (file-exists? fulldir))
+ (create-directory fulldir #t)) ;; need to protect with exception handler
+ (if (and target
+ runname
+ (file-exists? fulldir))
+ (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
+ (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))
+ (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
+ (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
+ (begin
+ (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
+ (configf:write-alist *configdat* tmpfile)
+ (system (conc "ln -sf " tmpfile " " targfile))))
+ )))))))
;; set up the very basics needed for doing anything here.
-(define (launch:setup-for-run #!key (force #f))
+;;
+(define (launch:setup-old #!key (force #f))
;; would set values for KEYS in the environment here for better support of env-override but
;; 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
@@ -665,61 +718,137 @@
(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
(exit 1)))
)))
*toppath*)
-(define (launch:cache-config)
- ;; 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*
- (or (args:get-arg "-run")
- (args:get-arg "-runtests")
- (args:get-arg "-execute")))
- (let* ((linktree (get-environment-variable "MT_LINKTREE"))
- (target (common:args-get-target))
- (runname (or (args:get-arg "-runname")
- (args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
- (fulldir (conc linktree "/"
- target "/"
- runname)))
- (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
- (if (file-exists? linktree) ;; can't proceed without linktree
- (begin
- (if (not (file-exists? fulldir))
- (create-directory fulldir #t)) ;; need to protect with exception handler
- (if (and target
- runname
- (file-exists? fulldir))
- (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
- (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))
- (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
- (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
- (begin
- (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
- (configf:write-alist *configdat* tmpfile)
- (system (conc "ln -sf " tmpfile " " targfile))))
- )))))))
-
;; gather available information, if legit read configs in this order:
;;
;; if have cache;
;; read it a return it
;; else
;; megatest.config (do not cache)
;; runconfigs.config (cache if all vars avail)
;; megatest.config (cache if all vars avail)
+;; returns:
+;; *toppath*
+;; side effects:
+;; sets; *configdat* (megatest.config info)
+;; *runconfigdat* (runconfigs.config info)
+;; *configstatus* (status of the read data)
;;
-(define (launch:setup #!key (force #f))
- (let* ((runname (common:args-get-runname))
+(define (launch:setup-new #!key (force #f))
+ (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
+ (runname (common:args-get-runname))
(target (common:args-get-target))
- (linktree (or (getenv "MT_LINKTREE")
- (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (linktree (common:get-linktree))
+ (sections (if target (list "default" target) #f)) ;; for runconfigs
+ (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
(rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
(mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))))
- #f))
+ (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
+ (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))))
+ ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
+ (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
+ (cond
+ ;; data was read and cached and available in *configstatus*, toppath has already been set
+ ((eq? *configstatus* 'fulldata)
+ *toppath*)
+ ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
+ ((and mtcachef (file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME"))
+ (set! *configdat* (configf:read-alist mtcachef))
+ (set! *runconfigdat* (configf:read-alist rccachef))
+ (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
+ (set! *configstatus* 'fulldata)
+ (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
+ *toppath*)
+ ;; we have all the info needed to fully process runconfigs and megatest.config
+ (mtcachef
+ (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
+ mtconfig
+ environ-patt: "env-override"
+ given-toppath: toppath
+ pathenvvar: "MT_RUN_AREA_HOME"))
+ (first-rundat (let ((toppath (if toppath
+ toppath
+ (car first-pass))))
+ (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t
+ sections: sections))))
+ (set! *runconfigdat* first-rundat)
+ (if first-pass ;;
+ (begin
+ (set! *configdat* (car first-pass))
+ (set! *configinfo* first-pass)
+ (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
+ (set! toppath *toppath*)
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
+ (let* ((keys (rmt:get-keys))
+ (key-vals (keys:target->keyval keys target))
+ (linktree (or (getenv "MT_LINKTREE")
+ (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (second-pass (find-and-read-config
+ mtconfig
+ environ-patt: "env-override"
+ given-toppath: toppath
+ pathenvvar: "MT_RUN_AREA_HOME"))
+ (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
+ (for-each (lambda (kt)
+ (setenv (car kt) (cadr kt)))
+ key-vals)
+ (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t
+ sections: sections))))
+ (if cancreate (configf:write-alist runconfigdat rccachef))
+ (set! *runconfigdat* runconfigdat)
+ (if cancreate (configf:write-alist *configdat* mtcachef))
+ (if cancreate (set! *configstatus* 'fulldata))))
+ ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
+ (set! *configdat* (make-hash-table))
+ )))
+ ;; else read what you can and set the flag accordingly
+ (else
+ (let* ((cfgdat (find-and-read-config
+ (or (args:get-arg "-config") "megatest.config")
+ environ-patt: "env-override"
+ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
+ pathenvvar: "MT_RUN_AREA_HOME")))
+ (if cfgdat
+ (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
+ (rdat (read-config (conc toppath
+ "/runconfigs.config") *runconfigdat* #t sections: sections)))
+ (set! *configinfo* cfgdat)
+ (set! *configdat* (car cfgdat))
+ (set! *runconfigdat* rdat)
+ (set! *toppath* toppath)
+ (set! *configstatus* 'partial))
+ (begin
+ (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.")
+ (exit 2))))))
+ ;; additional house keeping
+ (let* ((linktree (or (getenv "MT_LINKTREE")
+ (if *configdat* (configf:lookup *configdat* "setup" "linktree") #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))
+ (exit 1))
+ (create-directory linktree #t))))
+ (begin
+ (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
+ ;; (exit 1)
+ )))
+ (if (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.")))
+ *toppath*))
+
+(define launch:setup launch:setup-new)
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -468,11 +468,11 @@
(begin
(save-environment-as-files (args:get-arg "-env2file"))
(set! *didsomething* #t)))
(if (args:get-arg "-list-disks")
- (let ((toppath (launch:setup-for-run)))
+ (let ((toppath (launch:setup)))
(print
(string-intersperse
(map (lambda (x)
(string-intersperse
x
@@ -720,11 +720,11 @@
(if (args:get-arg "-server")
;; Server? Start up here.
;;
- (let ((tl (launch:setup-for-run))
+ (let ((tl (launch:setup))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(if run-id
(begin
(server:launch run-id)
@@ -740,11 +740,11 @@
'("-list-servers"
"-stop-server"
"-show-cmdinfo"
"-list-runs"
"-ping")))
- (if (launch:setup-for-run)
+ (if (launch:setup)
(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")
@@ -760,11 +760,11 @@
;; MAY STILL NEED THIS
;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
- (let ((tl (launch:setup-for-run)))
+ (let ((tl (launch:setup)))
(if tl
(let* ((tdbdat (tasks:open-db))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
(servers-to-kill '())
@@ -830,10 +830,17 @@
(set! *didsomething* #t)))
;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
+;; in the envprocessing branch the below code replaces the further below code
+;; (if (eq? *configstatus* 'fulldata)
+;; *runconfigdat*
+;; (begin
+;; (launch:setup)
+;; *runconfigdat*)))
+
(let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
#f))
(cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
(if (and cfgf
@@ -855,16 +862,16 @@
(directory-exists? rundir)
(file-write-access? rundir))
(begin
(configf:write-alist data cfgf)
;; force re-read of megatest.config - this resolves circular references between megatest.config
- (launch:setup-for-run force: #t)
+ (launch:setup force: #t)
(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
data))))
(if (args:get-arg "-show-runconfig")
- (let ((tl (launch:setup-for-run)))
+ (let ((tl (launch:setup)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
;; keep this one local
(cond
((and (args:get-arg "-section")
@@ -882,11 +889,11 @@
(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t))
(pop-directory)))
(if (args:get-arg "-show-config")
- (let ((tl (launch:setup-for-run))
+ (let ((tl (launch:setup))
(data *configdat*)) ;; (read-config "megatest.config" #f #t)))
(push-directory *toppath*)
;; keep this one local
(cond
((and (args:get-arg "-section")
@@ -1019,11 +1026,11 @@
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
- (if (launch:setup-for-run)
+ (if (launch:setup)
(let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
(runpatt (args:get-arg "-list-runs"))
(testpatt (common:args-get-testpatt #f))
;; (if (args:get-arg "-testpatt")
;; (args:get-arg "-testpatt")
@@ -1350,11 +1357,11 @@
(set! *didsomething* #t))))
;; Don't think I need this. Incorporated into -list-runs instead
;;
;; (if (and (args:get-arg "-since")
-;; (launch:setup-for-run))
+;; (launch:setup))
;; (let* ((since-time (string->number (args:get-arg "-since")))
;; (run-ids (db:get-changed-run-ids since-time)))
;; ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;; (print (sort run-ids <))
;; (set! *didsomething* #t)))
@@ -1508,11 +1515,11 @@
(change-directory toppath)
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
(let* ((keys (rmt:get-keys))
;; db:test-get-paths must not be run remote
@@ -1614,11 +1621,11 @@
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(rmt:teststep-set-status! run-id test-id step state status msg logfile)
@@ -1662,11 +1669,11 @@
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f) ;; (open-db))
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
@@ -1767,11 +1774,11 @@
(if (or (args:get-arg "-showkeys")
(args:get-arg "-show-keys"))
(let ((db #f)
(keys #f))
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (rmt:get-keys)) ;; db))
(debug:print 1 "Keys: " (string-intersperse keys ", "))
@@ -1798,21 +1805,21 @@
;; Update the database schema, clean up the db
;;======================================================================
(if (args:get-arg "-rebuild-db")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; keep this one local
(open-run-close patch-db #f)
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; keep this one local
;; (open-run-close db:clean-up #f)
@@ -1827,11 +1834,11 @@
)
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting") b
(exit 1)))
(open-run-close db:find-and-mark-incomplete #f)
(set! *didsomething* #t)))
@@ -1840,11 +1847,11 @@
;; Update the tests meta data from the testconfig files
;;======================================================================
(if (args:get-arg "-update-meta")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
;; keep this one local
@@ -1857,11 +1864,11 @@
;; fakeout readline
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
- (let* ((toppath (launch:setup-for-run))
+ (let* ((toppath (launch:setup))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if dbstruct
(begin
(set! *db* dbstruct)
(set! *client-non-blocking-mode* #t)
@@ -1888,11 +1895,11 @@
(if (and (args:get-arg "-run-wait")
(not (or (args:get-arg "-run")
(args:get-arg "-runtests")))) ;; run-wait is built into runtests now
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(operate-on 'run-wait)
(set! *didsomething* #t)))
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -67,11 +67,11 @@
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
-(if (not (launch:setup-for-run))
+(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
;; (if (args:get-arg "-host")
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -147,11 +147,27 @@
;; possibly pid is a process not a child, look in /proc to see if it is running still
(file-exists? (conc "/proc/" pid))
(let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
(and (number? rpid)
(equal? rpid pid)))))
-
+
+(define (process:alive-on-host? host pid)
+ (let ((cmd (conc "ssh " host " ps -o pid= -p " pid)))
+ (handle-exceptions
+ exn
+ #f ;; anything goes wrong - assume the process in NOT running.
+ (with-input-from-pipe
+ cmd
+ (lambda ()
+ (let loop ((inl (read-line)))
+ (if (eof-object? inl)
+ #f
+ (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl))
+ (innum (string->number clean-str)))
+ (and innum
+ (eq? pid innum))))))))))
+
(define (process:get-sub-pids pid)
(with-input-from-pipe
(conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid)
(lambda ()
(let loop ((inl (read-line))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -40,11 +40,11 @@
;; NOT YET UTILIZED
;;
(define (runs:create-run-record)
(let* ((mconfig (if *configdat*
*configdat*
- (if (launch:setup-for-run)
+ (if (launch:setup)
*configdat*
(begin
(debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
(exit 1)))))
(runrec (runs:runrec-make-record))
@@ -73,18 +73,25 @@
(set! envdat (append
envdat
(list (list "MT_RUN_AREA_HOME" toppath)
(list "MT_RUNNAME" runname)
(list "MT_TARGET" target))))
- ;; Now can read the runconfigs file
+
+ ;; Now can read the runconfigs file -- can replace this with call to launch:setup?
+ ;;
+ ;; This block should be ok to remove - just keep the set of runconfig
;;
- (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
- (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
+ (if (not (eq? *configstatus* 'fulldata))
(begin
- (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
- (if db (sqlite3:finalize! db))
- (exit 1)))
+ (debug:print 0 "Processing runconfigs.config again...")
+ (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
+ (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
+ (begin
+ (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
+ (if db (sqlite3:finalize! db))
+ (exit 1))))
+ (set! runconfig *runconfigdat*))
;; Now have runconfigs data loaded, set environment vars
;; Only now can we calculate the testpatt
(set! testpatt (common:args-get-testpatt runconfig))
@@ -226,11 +233,11 @@
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
-(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names
+(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
@@ -1780,11 +1787,11 @@
(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)
+ (if (launch:setup)
(begin
(full-runconfigs-read) ;; cache the run config
(launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed
(begin
(debug:print 0 "Failed to setup, exiting")
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -207,11 +207,11 @@
(let ((tdbdat (tasks:open-db)))
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
- (toppath (launch:setup-for-run))
+ (toppath (launch:setup))
(server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
(if (not run-id)
(begin
(debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
(print "ERROR: No run-id")
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -735,45 +735,56 @@
(getenv "MT_TEST_NAME") "/"
(if (or (getenv "MT_ITEMPATH")
(not (string=? "" (getenv "MT_ITEMPATH"))))
(conc "/" (getenv "MT_ITEMPATH"))))))
+;; if .testconfig exists in test directory read and return it
+;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
+;; else read the testconfig file
+;; if have path to test directory save the config as .testconfig and return it
+;;
(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f))
- (let* ((treg (or test-registry
- (tests:get-all)))
- (test-path (hash-table-ref/default
- treg test-name
- (conc *toppath* "/tests/" test-name)))
- (test-configf (conc test-path "/testconfig"))
- (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
- (cache-path (tests:get-test-path-from-environment))
- (cache-exists (and cache-path
+ (let* ((cache-path (tests:get-test-path-from-environment))
+ (cache-file (and cache-path (conc cache-path "/.testconfig")))
+ (cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
- (file-exists? (conc cache-path "/.testconfig"))))
- (cache-file (conc cache-path "/.testconfig"))
- (tcfg (if testexists
- (or (and (not force-create)
- cache-exists
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "WARNING: Failed to read " cache-file)
- (make-hash-table)) ;; better to return a hash and keep going - I think
- (configf:read-alist cache-file)))
- (read-config test-configf #f system-allowed environ-patt: (if system-allowed
- "pre-launch-env-vars"
- #f)))
- #f)))
- (hash-table-set! *testconfigs* test-name tcfg)
- (if (and testexists
- cache-path
- (not cache-exists)
- (file-write-access? cache-path))
- (let ((tpath (conc cache-path "/.testconfig")))
- (debug:print-info 1 "Caching testconfig for " test-name " in " tpath)
- (configf:write-alist tcfg tpath)))
- tcfg))
+ (file-exists? cache-file)))
+ (cached-dat (if (and (not force-create)
+ cache-exists)
+ (handle-exceptions
+ exn
+ #f ;; any issues, just give up with the cached version and re-read
+ (configf:read-alist cache-file))
+ #f)))
+ (if cached-dat
+ cached-dat
+ (let ((dat (hash-table-ref/default *testconfigs* test-name #f)))
+ (if (and dat ;; have a locally cached version
+ (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
+ dat
+ ;; no cached data available
+ (let* ((treg (or test-registry
+ (tests:get-all)))
+ (test-path (or (hash-table-ref/default treg test-name #f)
+ (conc *toppath* "/tests/" test-name)))
+ (test-configf (conc test-path "/testconfig"))
+ (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
+ (tcfg (if testexists
+ (read-config test-configf #f system-allowed
+ environ-patt: (if system-allowed
+ "pre-launch-env-vars"
+ #f))
+ #f)))
+ (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
+ (if tcfg (hash-table-set! *testconfigs* test-name tcfg))
+ (if (and testexists
+ cache-file
+ (file-write-access? cache-path))
+ (let ((tpath (conc cache-path "/.testconfig")))
+ (debug:print-info 1 "Caching testconfig for " test-name " in " tpath)
+ (configf:write-alist tcfg tpath)))
+ tcfg))))))
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
(let* ((mungepriority (lambda (priority)
@@ -849,10 +860,11 @@
(let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
(let ((all-testnames (hash-table-keys test-records))
(temp-port (open-output-file* fd)))
;; (format temp-port "This file is ~A.~%" temp-path)
(format temp-port "digraph tests {\n")
+ (format temp-port " size=4,8\n")
;; (format temp-port " splines=none\n")
(for-each
(lambda (testname)
(let* ((testrec (hash-table-ref test-records testname))
(waitons (or (tests:testqueue-get-waitons testrec) '())))
@@ -880,11 +892,13 @@
(let ((all-testnames (hash-table-keys test-records)))
(if (null? all-testnames)
'()
(let loop ((hed (car all-testnames))
(tal (cdr all-testnames))
- (res (list "digraph tests {")))
+ (res (list "digraph tests {"
+ " size=\"11,11\";"
+ " ratio=0.95;")))
(let* ((testrec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(newres (append res
(if (null? waitons)
(list (conc " \"" hed "\";"))
Index: tests/fullrun/configs/mt_include_2.config
==================================================================
--- tests/fullrun/configs/mt_include_2.config
+++ tests/fullrun/configs/mt_include_2.config
@@ -1,2 +1,2 @@
[disks]
-disk0 #{getenv MT_RUN_AREA_HOME}/tmp/mt_runs
+disk0 #{scheme (create-directory "#{getenv MT_RUN_AREA_HOME}/tmp/mt_runs" #t)}
Index: tests/fullrun/megatest.config
==================================================================
--- tests/fullrun/megatest.config
+++ tests/fullrun/megatest.config
@@ -94,13 +94,10 @@
# (nb// this is in addition to NOT_STARTED which is automatically re-run)
#
allow-auto-rerun INCOMPLETE ZERO_ITEMS
# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD
-# Try this
-reruns 0
-
[validvalues]
state start end 0 1 - 2
status pass fail n/a 0 1 running - 2
# These are set before all tests, override them
Index: tests/fullrun/runconfigs.config
==================================================================
--- tests/fullrun/runconfigs.config
+++ tests/fullrun/runconfigs.config
@@ -1,7 +1,9 @@
[default]
SOMEVAR This should show up in SOMEVAR3
+VARNOVAL
+VARNOVAL_WITHSPACE
# target based getting of config file, look at afs.config and nfs.config
[include #{getenv fsname}.config]
[include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config]
Index: tests/fullrun/tests/all_toplevel/testconfig
==================================================================
--- tests/fullrun/tests/all_toplevel/testconfig
+++ tests/fullrun/tests/all_toplevel/testconfig
@@ -1,7 +1,12 @@
[ezsteps]
calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET
+check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat
+
+[logpro]
+check_triggers ;;
+ (expect:error in "LogFileBody" = 0 "No errors" #/error/i)
[requirements]
waiton #{getenv ALL_TOPLEVEL_TESTS}
# This is a "toplevel" test, it does not require waitons to be non-FAIL to run
Index: tests/fullrun/tests/exit_0/testconfig
==================================================================
--- tests/fullrun/tests/exit_0/testconfig
+++ tests/fullrun/tests/exit_0/testconfig
@@ -8,8 +8,10 @@
tags first,single
reviewed 09/10/2011, by Matt
[triggers]
-NOT_STARTED/ xterm -e bash -s --
-RUNNING/ xterm -e bash -s --
+# NOT_STARTED/ xterm -e bash -s --
+NOT_STARTED/ echo "trigger: exit_0, NOT_STARTED/" > $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat
+RUNNING/ echo "trigger: exit_0, RUNNING/" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat
+
Index: tests/fullrun/tests/ez_fail_quick/testconfig
==================================================================
--- tests/fullrun/tests/ez_fail_quick/testconfig
+++ tests/fullrun/tests/ez_fail_quick/testconfig
@@ -5,11 +5,11 @@
# should fail on next step
lookitnada ls /nada
[triggers]
# run like this: cmd test-id test-rundir trigger
-COMPLETED/FAIL xterm;echo
+COMPLETED/FAIL echo "trigger: ez_fail_quick, COMPLETED/FAIL" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat
[test_meta]
author matt
owner bob
description This test runs a single ezstep which fails immediately.
Index: tests/fullrun/tests/priority_1/testconfig
==================================================================
--- tests/fullrun/tests/priority_1/testconfig
+++ tests/fullrun/tests/priority_1/testconfig
@@ -12,6 +12,6 @@
tags first,single
reviewed 09/10/2011, by Matt
[triggers]
-COMPLETED/ echo $MT_TEST_NAME > $MT_RUN_AREA_HOME/foo
+COMPLETED/ echo "trigger: priority_1, COMPLETED/" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat
Index: tests/fullrun/tests/test_mt_vars/testconfig
==================================================================
--- tests/fullrun/tests/test_mt_vars/testconfig
+++ tests/fullrun/tests/test_mt_vars/testconfig
@@ -22,17 +22,35 @@
test-path test-path-file.sh
# verify that vars with $ signs get expanded
varwithdollar eval_vars.sh
+emptyvars bash -c 'if [[ $VARNOVAL == "" ]];then echo HAVE_VARNOVAL;else echo "ERROR: VARNOVAL not found";fi'
+emptyvar_withspace bash -c 'if [[ $VARNOVAL_WITHSPACE == "" ]];then echo HAVE_VARNOVAL_WITHSPACE;else echo "ERROR: VARNOVAL_WITHSPACE not found";fi'
+emptyvar_megatest.sh egrep VARNO megatest.sh
+
[requirements]
waiton runfirst
priority 0
[items]
NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE]
+[logpro]
+emptyvars ;;
+ (expect:error in "LogFileBody" = 0 "VARNOVAL not found" #/ERROR: VARNOVAL not found/)
+ (expect:required in "LogFileBody" = 1 "HAVE_VARNOVAL" #/HAVE_VARNOVAL/)
+
+emptyvar_withspace ;;
+ (expect:error in "LogFileBody" = 0 "VARNOVAL_WITHSPACE not found" #/ERROR: VARNOVAL_WITHSPACE not found/)
+ (expect:required in "LogFileBody" = 1 "HAVE_VARNOVAL_WITHSPACE" #/HAVE_VARNOVAL_WITHSPACE/)
+
+emptyvar_megatest.sh ;;
+ (expect:error in "LogFileBody" = 0 "No errors expected" #/ERR/i)
+ (expect:required in "LogFileBody" = 1 "VARNOVAL_WITHSPACE" #/VARNOVAL_WITHSPACE/)
+ (expect:required in "LogFileBody" = 1 "VARNOVAL" #/VARNOVAL/)
+
[test_meta]
author matt
owner bob
description This test runs a single ezstep which is expected to pass, no logpro file.