Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -144,10 +144,11 @@
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
+ ((set-var) (apply db:set-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
;; TEST DATA
@@ -219,10 +220,11 @@
((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
+ ((get-var) (apply db:get-var dbstruct params))
;; STEPS
((get-steps-data) (apply db:get-steps-data dbstruct params))
((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
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,35 +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")))
+ (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 (hash-table? *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
@@ -656,11 +667,24 @@
;;======================================================================
(define (common:get-disk-space-used fpath)
(with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))
+;; given path get free space, allows override in [setup]
+;; with free-space-script /path/to/some/script.sh
+;;
(define (get-df path)
+ (if (configf:lookup *configdat* "setup" "free-space-script")
+ (with-input-from-pipe
+ (configf:lookup *configdat* "setup" "free-space-script")
+ (lambda ()
+ (let ((res (read-line)))
+ (if (string? res)
+ (string->number res)))))
+ (get-unix-df path)))
+
+(define (get-unix-df path)
(let* ((df-results (process:cmd-run->list (conc "df " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
(freespc #f))
;; (write df-results)
(for-each (lambda (l)
@@ -669,10 +693,39 @@
(let ((newval (string->number (cadr match))))
(if (number? newval)
(set! freespc newval))))))
(car df-results))
freespc))
+
+;; check space in dbdir
+;; returns: ok/not dbspace required-space
+;;
+(define (common:check-db-dir-space)
+ (let* ((dbdir (db:get-dbdir))
+ (dbspace (if (directory? dbdir)
+ (get-df dbdir)
+ 0))
+ (required (string->number
+ (or (configf:lookup *configdat* "setup" "dbdir-space-required")
+ "100000"))))
+ (list (> dbspace required)
+ dbspace
+ required
+ dbdir)))
+
+;; check available space in dbdir, exit if insufficient
+;;
+(define (common:check-db-dir-and-exit-if-insufficient)
+ (let* ((spacedat (common:check-db-dir-space))
+ (is-ok (car spacedat))
+ (dbspace (cadr spacedat))
+ (required (caddr spacedat))
+ (dbdir (cadddr spacedat)))
+ (if (not is-ok)
+ (begin
+ (debug:print 0 "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
+ (exit 1)))))
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
(let ((best #f)
@@ -708,11 +761,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))
@@ -720,11 +778,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))
@@ -733,11 +791,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))
@@ -239,23 +348,24 @@
test1-older)
(if same-time
(string>? test-name1 test-name2)
test1-older))))
+;; 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
@@ -263,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
@@ -294,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)
@@ -443,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* '())
@@ -474,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)
@@ -518,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)
@@ -563,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
;;======================================================================
@@ -631,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
@@ -756,16 +861,13 @@
;; (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 '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)))))))
(dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
))
;;======================================================================
@@ -794,15 +896,14 @@
(dashboard:update-run-command))))
(tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
(test-patterns-textbox #f))
(hash-table-set! tests-draw-state 'first-time #t)
;; (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
@@ -867,13 +968,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"))
@@ -952,70 +1053,64 @@
(set! the-cnv cnv)
))
;; Following doesn't work
#:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
(let ((scalef (hash-table-ref tests-draw-state 'scalef)))
- ;; (debug:print 0 "step=" step ", dir=" dir ", scalef=" scalef ", x=" x ", y=" y)
- ;; (let (;; (xadj last-xadj)
- ;; (yadj (+ last-yadj (if (> step 0)
- ;; -0.01
- ;; 0.01))))
(hash-table-set! tests-draw-state 'scalef (+ scalef
(if (> step 0)
- 0.01
- -0.01)))
-
- ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"")
- ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir)
+ (* scalef 0.01)
+ (* scalef -0.01))))
(if the-cnv
(dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
- ;; (set! last-xadj xadj)
- ;; (set! last-yadj yadj)
))
;; #:size "50x50"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
- (print "obj: " obj ", pressed " pressed ", status " status)
- (print "canvas-origin: " (canvas-origin the-cnv))
- (let-values (((xx yy)(canvas-origin the-cnv)))
- (canvas-transform-set! the-cnv #f)
- (print "canvas-origin: " xx " " yy " click at " x " " y))
- (let ((tests-info (hash-table-ref tests-draw-state 'tests-info))
- (selected-tests (hash-table-ref tests-draw-state 'selected-tests)))
+ ;; (print "obj: " obj ", pressed " pressed ", status " status)
+ ; (print "canvas-origin: " (canvas-origin the-cnv))
+ ;; (let-values (((xx yy)(canvas-origin the-cnv)))
+ ;; (canvas-transform-set! the-cnv #f)
+ ;; (print "canvas-origin: " xx " " yy " click at " x " " y))
+ (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info))
+ (selected-tests (hash-table-ref tests-draw-state 'selected-tests))
+ (scalef (hash-table-ref tests-draw-state 'scalef))
+ (sizey (hash-table-ref tests-draw-state 'sizey))
+ (xoffset (dcommon:get-xoffset tests-draw-state #f #f))
+ (yoffset (dcommon:get-yoffset tests-draw-state #f #f))
+ (new-y (- sizey y)))
+ ;; (print "xoffset=" xoffset ", yoffset=" yoffset)
;; (print "\tx\ty\tllx\tlly\turx\tury")
(for-each (lambda (test-name)
(let* ((rec-coords (hash-table-ref tests-info test-name))
- (llx (list-ref rec-coords 0))
- (urx (list-ref rec-coords 1))
- (lly (list-ref rec-coords 2))
- (ury (list-ref rec-coords 3)))
- ;; (print "\t" x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " ")
+ (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset))
+ (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset))
+ (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset))
+ (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset)))
+ ;; (if (eq? pressed 1)
+ ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " "))
(if (and (eq? pressed 1)
- (> x llx)
- (> y lly)
- (< x urx)
- (< y ury))
+ (>= x llx)
+ (>= new-y lly)
+ (<= x urx)
+ (<= new-y ury))
(let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
(let* ((selected (not (member test-name patterns)))
(newpatt-list (if selected
(cons test-name patterns)
(delete test-name patterns)))
(newpatt (string-intersperse newpatt-list "\n")))
- ;; (if cnv-obj
- ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames))
(iup:attribute-set! obj "REDRAW" "ALL")
(hash-table-set! selected-tests test-name selected)
(iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
(dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
(dashboard:update-run-command)
(if updater (updater last-xadj last-yadj)))))))
(hash-table-keys tests-info)))))))
canvas-obj)))
- ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status))
(iup:frame
#:title "Logs" ;; To be replaced with tabs
(let ((logs-tb (iup:textbox #:expand "YES"
#:multiline "YES")))
@@ -1088,32 +1183,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))
@@ -1122,36 +1392,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))
@@ -1163,11 +1436,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)
@@ -1186,25 +1459,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")
@@ -1260,20 +1533,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))
@@ -1315,32 +1588,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*))
@@ -1353,38 +1626,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
@@ -1408,13 +1681,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"
@@ -1467,17 +1740,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
@@ -1490,60 +1763,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)
@@ -1553,50 +1830,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
;;======================================================================
@@ -1604,73 +1883,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
@@ -145,12 +145,11 @@
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
(define (db:dbfile-path run-id)
- (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir")
- (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
+ (let* ((dbdir (db:get-dbdir))
(fname (if run-id
(if (eq? run-id 0) "main.db" (conc run-id ".db"))
#f)))
(handle-exceptions
exn
@@ -159,10 +158,14 @@
(exit 1))
(if (not (directory? dbdir))(create-directory dbdir #t)))
(if fname
(conc dbdir "/" fname)
dbdir)))
+
+(define (db:get-dbdir)
+ (or (configf:lookup *configdat* "setup" "dbdir")
+ (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))
@@ -728,11 +731,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
@@ -1583,17 +1586,14 @@
;; also updates *global-delta*
;;
;; Operates on megatestdb
;;
(define (db:get-var dbstruct var)
- (let* ((start-ms (current-milliseconds))
- (throttle (let ((t (config-lookup *configdat* "setup" "throttle")))
- (if t (string->number t) t)))
- (res #f)
+ (let* ((res #f)
(dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
- (db:delay-if-busy dbdat)
+ ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM metadat WHERE var=?;" var)
@@ -1600,23 +1600,22 @@
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
;; scale by 10, average with current value.
- (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
- (if throttle throttle 0.01)))
- 2))
- (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
- (begin
- (debug:print-info 4 "launch throttle factor=" *global-delta*)
- (set! *last-global-delta-printed* *global-delta*)))
+;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
+;; (if throttle throttle 0.01)))
+;; 2))
+;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
+;; (begin
+;; (debug:print-info 4 "launch throttle factor=" *global-delta*)
+;; (set! *last-global-delta-printed* *global-delta*)))
res))
(define (db:set-var dbstruct var val)
- (let ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- (db:delay-if-busy dbdat)
+ (let* ((dbdat (db:get-db dbstruct #f))
+ (db (db:dbdat-get-db dbdat)))
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))
(define (db:del-var dbstruct var)
;; (db:delay-if-busy)
(db:with-db dbstruct #f #t
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 )
@@ -579,16 +590,16 @@
;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================
-(define (dcommon:draw-test cnv scalef x y w h name selected)
- (let* ((llx (* scalef x))
- (lly (* scalef y))
- (urx (* scalef (+ x w)))
- (ury (* scalef (+ y h))))
- (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")"))
+(define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected)
+ (let* ((llx (dcommon:x->canvas x scalef xoffset))
+ (lly (dcommon:y->canvas y scalef yoffset))
+ (urx (dcommon:x->canvas (+ x w) scalef xoffset))
+ (ury (dcommon:y->canvas (+ y h) scalef yoffset)))
+ (canvas-text! cnv (+ llx 5)(+ lly 5) name)
(canvas-rectangle! cnv llx urx lly ury)
(if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))
(define (dcommon:draw-arrow cnv test-box-center waiton-center)
(let* ((test-box-center-x (vector-ref test-box-center 0))
@@ -630,33 +641,41 @@
)
(canvas-mark! cnv new-waiton-x new-waiton-y)))
(define (dcommon:get-box-center box)
(let* ((llx (list-ref box 0))
- (lly (list-ref box 4))
- (boxw (list-ref box 5))
- (boxh (list-ref box 6)))
+ (lly (list-ref box 1))
+ (boxw (list-ref box 4))
+ (boxh (list-ref box 5)))
(vector (+ llx (/ boxw 2))
(+ lly (/ boxh 2)))))
(define-inline (num->int num)
(inexact->exact (round num)))
-(define (dcommon:draw-edges cnv scalef edges)
+(define (dcommon:draw-edges cnv xoffset yoffset scalef edges)
(for-each
(lambda (e)
(let loop ((x1 (car e))
(y1 (cadr e))
(x2 #f)
(y2 #f)
(tal (cddr e)))
(if (and x1 y1 x2 y2)
- (canvas-line! cnv x1 y1 x2 y2)) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2)))
+ (canvas-line!
+ cnv
+ (num->int (dcommon:x->canvas x1 scalef xoffset))
+ (num->int (dcommon:y->canvas y1 scalef yoffset))
+ (num->int (dcommon:x->canvas x2 scalef xoffset))
+ (num->int (dcommon:y->canvas y2 scalef yoffset)))) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2)))
(if (< (length tal) 2)
- (canvas-mark! cnv x1 y1) ;; (num->int x1)(num->int y1))
+ (canvas-mark! cnv
+ (num->int (dcommon:x->canvas x1 scalef xoffset))
+ (num->int (dcommon:y->canvas y1 scalef yoffset))) ;; (num->int x1)(num->int y1))
(loop (car tal)(cadr tal) x1 y1 (cddr tal)))))
- (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges)))
+ ;; (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges)))
+ edges))
(define (dcommon:draw-arrows cnv testname tests-hash test-records)
(let* ((test-box-info (hash-table-ref tests-hash testname))
(test-box-center (dcommon:get-box-center test-box-info))
@@ -670,81 +689,146 @@
waitons)
;; (debug:print 0 "test-box-info=" test-box-info)
;; (debug:print 0 "test-record=" test-record)
))
+(define (dcommon:estimate-scale sizex sizey originx originy nodes)
+ ;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes)
+ (let* ((maxx 1)
+ (maxy 1))
+ (for-each
+ (lambda (node)
+ (if (equal? (car node) "node")
+ (let ((x (string->number (list-ref node 2)))
+ (y (string->number (list-ref node 3))))
+ (if (and x (> x maxx))(set! maxx x))
+ (if (and y (> y maxy))(set! maxy y)))))
+ nodes)
+ (let ((scalex (/ sizex maxx))
+ (scaley (/ sizey maxy)))
+ ;; (print "maxx: " maxx " maxy: " maxy " scalex: " scalex " scaley: " scaley)
+ (min scalex scaley))))
+
+(define (dcommon:get-xoffset tests-draw-state sizex-in xadj-in)
+ (let ((xadj (or xadj-in (hash-table-ref/default tests-draw-state 'xadj 0)))
+ (sizex (or sizex-in (hash-table-ref/default tests-draw-state 'sizex 500))))
+ (hash-table-set! tests-draw-state 'xadj xadj) ;; for use in de-scaling when handling mouse clicks
+ (hash-table-set! tests-draw-state 'sizex sizex)
+ (* (/ sizex 2) (- 0.5 xadj))))
+
+(define (dcommon:get-yoffset tests-draw-state sizey-in yadj-in)
+ (let ((yadj (or yadj-in (hash-table-ref/default tests-draw-state 'yadj 0)))
+ (sizey (or sizey-in (hash-table-ref/default tests-draw-state 'sizey 500))))
+ (hash-table-set! tests-draw-state 'yadj yadj) ;; for use in de-scaling when handling mouse clicks
+ (hash-table-set! tests-draw-state 'sizey sizey)
+ (* (/ sizey 2) (- yadj 0.5))))
+
+(define (dcommon:x->canvas x scalef xoffset)
+ (+ xoffset (* x scalef)))
+
+(define (dcommon:y->canvas y scalef yoffset)
+ (+ yoffset (* y scalef)))
+
+;; sizex, sizey - canvas size
+;; originx, originy - canvas origin
+;;
(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
(let* ((dot-data ;; (map cdr (filter
;; (lambda (x)(equal? "node" (car x)))
- (map string-split (tests:lazy-dot test-records "plain"))) ;; (tests:easy-dot test-records "plain")))
- (scalef (hash-table-ref tests-draw-state 'scalef))
- (dotscale (hash-table-ref tests-draw-state 'dotscale))
- (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
- (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
- (xtorig (+ test-browse-xoffset (* (/ sizex 2) 1 (- 0.5 xadj)))) ;; (- xadj 1))))
- (ytorig (+ test-browse-yoffset (* (/ sizey 2) 1 (- yadj 0.5))))
- (boxw 10)
- (tests-hash (hash-table-ref tests-draw-state 'tests-info))
- (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
- ;; (print "dot-data=" dot-data)
- (hash-table-set! tests-draw-state 'xtorig xtorig)
- (hash-table-set! tests-draw-state 'ytorig ytorig)
+ (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain")))
+ (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj))
+ (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj))
+ (no-dot (configf:lookup *configdat* "setup" "nodot"))
+ (boxh 15)
+ (boxw 10)
+ (margin 5)
+ (tests-info (hash-table-ref tests-draw-state 'tests-info))
+ (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))
+ (scalef (if no-dot
+ 1
+ (dcommon:estimate-scale sizex sizey originx originy dot-data)))
+ (sorted-testnames (if no-dot
+ (sort sorted-testnames string>=?)
+ sorted-testnames))
+ (curr-x 0) ;; NB// NOT screen units
+ (curr-y (/ (- sizey boxh margin) scalef)) ;; used when no-dot
+ (scaled-sizex (/ sizex scalef)))
+
+ (hash-table-set! tests-draw-state 'scalef scalef)
+
(let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
(let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
(if (not (null? sorted-testnames))
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames))))
- (let* ((nodedat (let ((tmpres (filter (lambda (x)
- (if (and (not (null? x))
- (equal? (car x) "node"))
- (equal? hed (cadr x))
- #f))
- dot-data)))
- (if (null? tmpres)
- ;; llx lly boxw boxh
- (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some junk
- (car tmpres))))
- (edgedat (let ((edges (filter (lambda (x) ;; filter for edge
- (if (and (not (null? x))
- (equal? (car x) "edge"))
- (equal? hed (cadr x))
- #f))
- dot-data)))
- (map (lambda (inlst)
- (dcommon:process-polyline
- (map (lambda (instr)
- (* dotscale (string->number instr))) ;; convert to number and scale
- (let ((il (cddddr inlst)))
- (take il (- (length il) 2))))
- (lambda (x y)
- (list (+ x xtorig)
- (+ y ytorig)))
- #f #f)) ;; process polyline
- edges)))
- (llx (* (string->number (list-ref nodedat 2)) dotscale))
- (lly (* (string->number (list-ref nodedat 3)) dotscale))
- (boxw (* (string->number (list-ref nodedat 4)) dotscale))
- (boxh (* (string->number (list-ref nodedat 5)) dotscale))
+ (let* ((nodedat (if no-dot
+ #f
+ (let ((tmpres (filter (lambda (x)
+ (if (and (not (null? x))
+ (equal? (car x) "node"))
+ (equal? hed (cadr x))
+ #f))
+ dot-data)))
+ (if (null? tmpres)
+ ;; llx lly boxw boxh
+ (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some placeholder junk if no dat found
+ (car tmpres)))))
+ (edgedat (if no-dot
+ '()
+ (let ((edges (filter (lambda (x) ;; filter for edge
+ (if (and (not (null? x))
+ (equal? (car x) "edge"))
+ (equal? hed (cadr x))
+ #f))
+ dot-data)))
+ (map (lambda (inlst)
+ (dcommon:process-polyline
+ (map (lambda (instr)
+ (string->number instr)) ;; convert to number and scale
+ (let ((il (cddddr inlst)))
+ (take il (- (length il) 2))))
+ (lambda (x y)
+ (list (+ x 0) ;; xtorig)
+ (+ y 0))) ;; ytorig)))
+ #f #f)) ;; process polyline
+ edges))))
+ (llx (if no-dot
+ curr-x
+ (string->number (list-ref nodedat 2))))
+ (lly (if no-dot
+ curr-y
+ (string->number (list-ref nodedat 3))))
+ (boxw (if no-dot
+ boxw
+ (string->number (list-ref nodedat 4))))
+ (boxh (if no-dot
+ boxh
+ (string->number (list-ref nodedat 5))))
(urx (+ llx boxw))
(ury (+ lly boxh)))
+
+ ;; if we are in no-dot mode then increment curr-x and curr-y as needed
+ (if no-dot
+ (begin
+ (cond
+ ((< curr-x (- scaled-sizex boxw boxw margin))
+ (set! curr-x (+ curr-x boxw margin)))
+ ((> curr-x (- scaled-sizex boxw boxw margin))
+ (set! curr-x 0)
+ (set! curr-y (- curr-y (+ boxh margin)))))))
; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
- (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
- ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
- (dcommon:draw-edges cnv scalef edgedat)
+ (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
+ ;; (dcommon:draw-arrows cnv testname tests-info test-records))
+ (dcommon:draw-edges cnv xoffset yoffset scalef edgedat)
;; data used by mouse click calc. keep the wacky order for now.
- (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edgedat))
- ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
+ (hash-table-set! tests-info hed (list llx lly urx ury boxw boxh edgedat))
(if (not (null? tal))
(loop (car tal)
(cdr tal))))))
- ;; (for-each
- ;; (lambda (testname)
- ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
- ;; sorted-testnames))
))
;; per-point-proc required, remainder optional
;;
(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc)
@@ -764,48 +848,36 @@
(append res (per-point-proc x1 y1)))
(loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1)))))))
(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
(let* ((scalef (hash-table-ref tests-draw-state 'scalef))
- (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
- (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
- (xtorig (+ test-browse-xoffset (* (/ sizex 2) (- xadj 0.5)))) ;; (- xadj 1))))
- (ytorig (+ test-browse-yoffset (* (/ sizey 2) (- 0.5 yadj))))
- (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
- (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
- (tests-hash (hash-table-ref tests-draw-state 'tests-info))
+ (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj))
+ (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj))
+ (tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
- (hash-table-set! tests-draw-state 'xtorig xtorig)
- (hash-table-set! tests-draw-state 'ytorig ytorig)
(if (not (null? sorted-testnames))
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames))))
- (let* ((tvals (hash-table-ref tests-hash hed))
- (llx (+ xdelta (list-ref tvals 0)))
- (lly (+ ydelta (list-ref tvals 4)))
- (boxw (list-ref tvals 5))
- (boxh (list-ref tvals 6))
+ (let* ((tvals (hash-table-ref tests-info hed))
+ (llx (list-ref tvals 0))
+ (lly (list-ref tvals 1))
+ (boxw (list-ref tvals 4))
+ (boxh (list-ref tvals 5))
(edges (map (lambda (pline)
(dcommon:process-polyline pline
(lambda (x1 y1)
- (list (+ x1 xdelta)
- (+ y1 ydelta)))
+ (list x1 y1))
#f #f))
- (list-ref tvals 7)))
+ (list-ref tvals 6)))
(urx (+ llx boxw))
(ury (+ lly boxh)))
- (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
- (dcommon:draw-edges cnv scalef edges)
- (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edges))
+ (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
+ (dcommon:draw-edges cnv xoffset yoffset scalef edges)
(if (not (null? tal))
;; leave a column of space to the right to list items
(loop (car tal)
(cdr tal))))))))
- ;; (for-each
- ;; (lambda (testname)
- ;; (dcommon:draw-edges cnv scalef edges)) ;; (dcommon:draw-arrows cnv testname tests-hash test-records))
- ;; sorted-testnames)))
;;======================================================================
;; S T E P S
;;======================================================================
Index: docs/manual/Makefile
==================================================================
--- docs/manual/Makefile
+++ docs/manual/Makefile
@@ -1,8 +1,8 @@
ASCPATH = $(shell which asciidoc)
-EXEPATH = $(shell realpath $(ASCPATH))
+EXEPATH = $(shell readlink -f $(ASCPATH))
BINPATH = $(shell dirname $(EXEPATH))
DISPATH = $(shell dirname $(BINPATH))
# broad_goals.csv needed_features.csv : tables/*.dat
# ./refdb2csv tables
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
-<meta name="generator" content="AsciiDoc 8.6.9">
+<meta name="generator" content="AsciiDoc 8.6.7">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */
/* Default font. */
@@ -84,20 +84,14 @@
margin-top: 0;
}
ul > li { color: #aaa; }
ul > li > * { color: black; }
-.monospaced, code, pre {
- font-family: "Courier New", Courier, monospace;
- font-size: inherit;
- color: navy;
+pre {
padding: 0;
margin: 0;
}
-pre {
- white-space: pre-wrap;
-}
#author {
color: #527bbd;
font-weight: bold;
font-size: 1.1em;
@@ -222,11 +216,11 @@
border-left: 3px solid #dddddd;
padding-left: 0.5em;
}
div.imageblock div.content { padding-left: 0; }
-span.image img { border-style: none; vertical-align: text-bottom; }
+span.image img { border-style: none; }
a.image:visited { color: white; }
dl {
margin-top: 0.8em;
margin-bottom: 0.8em;
@@ -417,10 +411,16 @@
/*
* xhtml11 specific
*
* */
+
+tt {
+ font-family: "Courier New", Courier, monospace;
+ font-size: inherit;
+ color: navy;
+}
div.tableblock {
margin-top: 1.0em;
margin-bottom: 1.5em;
}
@@ -450,10 +450,16 @@
/*
* html5 specific
*
* */
+
+.monospaced {
+ font-family: "Courier New", Courier, monospace;
+ font-size: inherit;
+ color: navy;
+}
table.tableblock {
margin-top: 1.0em;
margin-bottom: 1.5em;
}
@@ -530,12 +536,10 @@
}
@media print {
body.manpage div#toc { display: none; }
}
-
-
@media screen {
body {
max-width: 50em; /* approximately 80 characters wide */
margin-left: 16em;
}
@@ -1153,10 +1157,33 @@
<div class="content monospaced">
<pre>[setup]
runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</pre>
</div></div>
</div>
+<div class="sect3">
+<h4 id="_tests_browser_view">Tests browser view</h4>
+<div class="paragraph"><p>The tests browser (see the Run Control tab on the dashboard) has two views for displaying the tests.</p></div>
+<div class="olist arabic"><ol class="arabic">
+<li>
+<p>
+Dot (graphviz) based tree
+</p>
+</li>
+<li>
+<p>
+No dot, plain listing
+</p>
+</li>
+</ol></div>
+<div class="paragraph"><p>The default is the graphviz based tree but if your tests don’t view
+well in that mode then use "nodot" to turn it off.</p></div>
+<div class="listingblock">
+<div class="content monospaced">
+<pre>[setup]
+nodot</pre>
+</div></div>
+</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_the_testconfig_file">The testconfig File</h2>
@@ -1177,17 +1204,15 @@
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_requirements_section">Requirements section</h3>
-<div class="sect3">
-<h4 id="_header_2">Header</h4>
<div class="listingblock">
+<div class="title">Header</div>
<div class="content monospaced">
<pre>[requirements]</pre>
</div></div>
-</div>
<div class="sect3">
<h4 id="_wait_on_other_tests">Wait on Other Tests</h4>
<div class="listingblock">
<div class="content monospaced">
<pre># A normal waiton waits for the prior tests to be COMPLETED
@@ -1218,10 +1243,25 @@
<div class="content monospaced">
<pre>[requirements]
mode itemmatch</pre>
</div></div>
</div>
+</div>
+<div class="sect2">
+<h3 id="_overriding_enviroment_variables">Overriding Enviroment Variables</h3>
+<div class="paragraph"><p>Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).</p></div>
+<div class="listingblock">
+<div class="content monospaced">
+<pre>[pre-launch-env-vars]
+VAR1 value1
+
+# Get some generated settings
+[include ../generated-vars.config]
+
+# Use this trick to unset variables
+#{scheme (unsetenv "FOOBAR")}</pre>
+</div></div>
</div>
<div class="sect2">
<h3 id="_itemmap_handling">Itemmap Handling</h3>
<div class="paragraph"><p>For cases were the dependent test has a similar but not identical
itempath to the downstream test an itemmap can allow for itemmatch
@@ -1291,11 +1331,11 @@
<pre>[requirements]
waiton A B
[itemmap]
A (\d+)/aa aa/\1
-B (\d+)/bb bb/\1</pre>
+B (\d+)/bb</pre>
</div></div>
<div class="listingblock">
<div class="title">Testconfig for Test D</div>
<div class="content monospaced">
<pre>[requirements]
@@ -1317,18 +1357,19 @@
<div class="content monospaced">
<pre>[requirements]
# With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
-# waiton #{shell get-valid-tests-to-run.sh}</pre>
+waiton #{shell get-valid-tests-to-run.sh}</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_run_time_limit_2">Run time limit</h4>
<div class="listingblock">
<div class="content monospaced">
-<pre>runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</pre>
+<pre>[requirements]
+runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip">Skip</h4>
<div class="paragraph"><p>A test with a skip section will conditional skip running.</p></div>
@@ -1445,11 +1486,11 @@
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
-<img src="/usr/images/icons/note.png" alt="Note">
+<img src="/nfs/pdx/disks/ice.disk.001/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
</div>
@@ -1485,10 +1526,53 @@
# <testsuite>/<creationdate>
# Within the archive the data is structured like this:
# <target>/<runname>/<test>/
archive0 /mfs/myarchive-data/adisk1</pre>
</div></div>
+</div>
+</div>
+<div class="sect1">
+<h2 id="_handling_environment_variables">Handling Environment Variables</h2>
+<div class="sectionbody">
+<div class="paragraph"><p>It is often necessary to capture and or manipulate environment
+variables. Megatest has some facilities built in to help.</p></div>
+<div class="sect2">
+<h3 id="_capture_variables">Capture variables</h3>
+<div class="listingblock">
+<div class="title">Commands</div>
+<div class="content monospaced">
+<pre># capture the current enviroment into a db called envdat.db under
+# the context "before"
+megatest -envcap before
+
+# capture the current environment into a db called startup.db with
+# context "after"
+megatest -envcap after startup.db
+
+# write the diff from before to after
+megatest -envdelta before-after -dumpmode bash</pre>
+</div></div>
+<div class="paragraph"><p>Dump modes include bash, csh and config. You can include config data
+into megatest.config or runconfigs.config.</p></div>
+<div class="listingblock">
+<div class="title">Example of generating and using config data</div>
+<div class="content monospaced">
+<pre>megatest -envcap original
+# do some stuff here
+megatest -envcap munged
+megatest -envdelta original-munged -dumpmode ini -o modified.config</pre>
+</div></div>
+<div class="paragraph"><p>Then in runconfigs.config</p></div>
+<div class="listingblock">
+<div class="title">Example of using modified.config in a testconfig</div>
+<div class="content monospaced">
+<pre>cat testconfig
+
+[pre-launch-env-vars]
+[include modified.config]</pre>
+</div></div>
+</div>
</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
@@ -1584,11 +1668,11 @@
<div class="sect2">
<h3 id="_appendix_sub_section">Appendix Sub-section</h3>
<div class="admonitionblock">
<table><tr>
<td class="icon">
-<img src="/usr/images/icons/note.png" alt="Note">
+<img src="/nfs/pdx/disks/ice.disk.001/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">Preface and appendix subsections start out of sequence at level
2 (level 1 is skipped). This only applies to multi-part book
documents.</td>
</tr></table>
@@ -1656,11 +1740,10 @@
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
-Last updated
- 2015-09-10 21:54:17 MST
+Last updated 2015-10-09 08:29:04 PDT
</div>
</div>
</body>
</html>
Index: docs/manual/reference.txt
==================================================================
--- docs/manual/reference.txt
+++ docs/manual/reference.txt
@@ -65,10 +65,26 @@
-----------------
[setup]
runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s
-----------------
+
+Tests browser view
+^^^^^^^^^^^^^^^^^^
+
+The tests browser (see the Run Control tab on the dashboard) has two views for displaying the tests.
+
+. Dot (graphviz) based tree
+. No dot, plain listing
+
+The default is the graphviz based tree but if your tests don't view
+well in that mode then use "nodot" to turn it off.
+
+-----------------
+[setup]
+nodot
+-----------------
The testconfig File
-------------------
Setup section
@@ -89,13 +105,11 @@
-------------------
Requirements section
~~~~~~~~~~~~~~~~~~~~
-Header
-^^^^^^
-
+.Header
-------------------
[requirements]
-------------------
Wait on Other Tests
@@ -132,10 +146,26 @@
-------------------
[requirements]
mode itemmatch
-------------------
+
+Overriding Enviroment Variables
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).
+
+--------------------
+[pre-launch-env-vars]
+VAR1 value1
+
+# Get some generated settings
+[include ../generated-vars.config]
+
+# Use this trick to unset variables
+#{scheme (unsetenv "FOOBAR")}
+--------------------
Itemmap Handling
~~~~~~~~~~~~~~~~
For cases were the dependent test has a similar but not identical
@@ -186,11 +216,12 @@
[requirements]
waiton A B
[itemmap]
A (\d+)/aa aa/\1
-B (\d+)/bb --------------------
+B (\d+)/bb
+----------------------
.Testconfig for Test D
----------------------
[requirements]
waiton C
@@ -384,10 +415,54 @@
# <testsuite>/<creationdate>
# Within the archive the data is structured like this:
# <target>/<runname>/<test>/
archive0 /mfs/myarchive-data/adisk1
--------------
+
+Handling Environment Variables
+------------------------------
+
+It is often necessary to capture and or manipulate environment
+variables. Megatest has some facilities built in to help.
+
+Capture variables
+~~~~~~~~~~~~~~~~~
+
+.Commands
+------------------------------
+# capture the current enviroment into a db called envdat.db under
+# the context "before"
+megatest -envcap before
+
+# capture the current environment into a db called startup.db with
+# context "after"
+megatest -envcap after startup.db
+
+# write the diff from before to after
+megatest -envdelta before-after -dumpmode bash
+------------------------------
+
+Dump modes include bash, csh and config. You can include config data
+into megatest.config or runconfigs.config.
+
+.Example of generating and using config data
+------------------------------
+megatest -envcap original
+# do some stuff here
+megatest -envcap munged
+megatest -envdelta original-munged -dumpmode ini -o modified.config
+------------------------------
+
+Then in runconfigs.config
+
+.Example of using modified.config in a testconfig
+------------------------------
+cat testconfig
+
+[pre-launch-env-vars]
+[include modified.config]
+------------------------------
Programming API
---------------
These routines can be called from the megatest repl.
Index: docs/manual/server.png
==================================================================
--- docs/manual/server.png
+++ docs/manual/server.png
cannot compute difference between binary files
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -27,11 +27,11 @@
(set-busy-handler! db (busy-timeout 10000))
db))
;; save vars in given context, this is NOT incremental by default
;;
-(define (env:save-env-vars db context #!key (incremental #f))
+(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
(with-transaction
db
(lambda ()
;; first clear out any vars for this context
(if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
@@ -39,40 +39,83 @@
(lambda (varval)
(let ((var (car varval))
(val (cdr varval)))
(if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
(exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
- (get-environment-variables)))))
+ (if vardat
+ (hash-table->alist vardat)
+ (get-environment-variables))))))
-;; apply contexts to current environment
+;; merge contexts in the order given
;; - each context is applied in the given order
;; - variables in the paths list are split on the separator and the components
;; merged using simple delta addition
+;; returns a hash of the merged vars
+;;
+(define (env:merge-contexts db basecontext contexts paths)
+ (let ((result (make-hash-table)))
+ (for-each
+ (lambda (context)
+ (query
+ (for-each-row
+ (lambda (row)
+ (let ((var (car row))
+ (val (cadr row)))
+ (hash-table-set! result var
+ (if (and (hash-table-ref/default results var #f)
+ (assoc var paths)) ;; this var is a path and there is a previous path
+ (let ((sep (cadr (assoc var paths))))
+ (env:merge-path-envvar sep (hash-table-ref results var) valb))
+ valb)))))
+ (sql db "SELECT var,val FROM envvars WHERE context=?")
+ context))
+ contexts)
+ result))
+
+;; get list of removed variables between two contexts
+;;
+(define (env:get-removed db contexta contextb)
+ (let ((result (make-hash-table)))
+ (query
+ (for-each-row
+ (lambda (row)
+ (let ((var (car row))
+ (val (cadr row)))
+ (hash-table-set! result var val))))
+ (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
+ contexta contextb)
+ result))
+
+;; get list of variables added to contextb from contexta
+;;
+(define (env:get-added db contexta contextb)
+ (let ((result (make-hash-table)))
+ (query
+ (for-each-row
+ (lambda (row)
+ (let ((var (car row))
+ (val (cadr row)))
+ (hash-table-set! result var val))))
+ (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
+ contextb contexta)
+ result))
+
+;; get list of variables in both contexta and contexb that have been changed
;;
-(define (env:apply-contexts db basecontext contexts paths outputf formats)
-
- (for-each
- (lambda (context)
- (query
- (for-each-row
- (lambda (row)
- (let ((var (car row))
- (vala (cadr row))
- (valb (caddr row)))
- ;;(print "var: " var " vala: " vala " valb" valb " paths: " paths)
- (if (assoc var paths) ;; this var is a PATH
- (let ((current (get-environment-variable var))) ;; use this NOT vala
- ;;(pp paths)
- ;;(pp var)
- (env:process-path-envvar var (cadr (assoc var paths)) current valb))
- (begin
- (setenv var valb))))))
- (sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val")
- ;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?")
- basecontext context))
- contexts))
-
+(define (env:get-changed db contexta contextb)
+ (let ((result (make-hash-table)))
+ (query
+ (for-each-row
+ (lambda (row)
+ (let ((var (car row))
+ (val (cadr row)))
+ (hash-table-set! result var val))))
+ (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")
+ contexta contextb)
+ result))
+
+;;
(define (env:blind-merge l1 l2)
(if (null? l1) l2
(if (null? l2) l1
(cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))
@@ -88,13 +131,10 @@
;; (print "AFTER: " (string-intersperse pathb-parts "\n "))
;; (print "COMMON: " (string-intersperse common-parts "\n "))
(string-intersperse final separator)))
(define (env:process-path-envvar varname separator patha pathb)
- (begin
- (print "Process-path-envvar: " varname)
- )
(let ((newpath (env:merge-path-envvar separator patha pathb)))
(setenv varname newpath)))
(define (env:have-context db context)
(> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
@@ -101,5 +141,71 @@
0))
;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
(close-database db))
+
+(define (env:lazy-hash-table->alist indat)
+ (if (hash-table? indat)
+ (let ((dat (hash-table->alist indat)))
+ (if (null? dat)
+ #f
+ dat))
+ #f))
+
+(define (env:print added removed changed)
+ (let ((a (env:lazy-hash-table->alist added))
+ (r (env:lazy-hash-table->alist removed))
+ (c (env:lazy-hash-table->alist changed)))
+ (case (if (args:get-arg "-dumpmode")
+ (string->symbol (args:get-arg "-dumpmode"))
+ 'bash)
+ ((bash)
+ (if a
+ (begin
+ (print "# Added vars")
+ (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
+ (hash-table->alist added))))
+ (if r
+ (begin
+ (print "# Removed vars")
+ (map (lambda (dat)(print "unset " (car dat)))
+ (hash-table->alist removed))))
+ (if c
+ (begin
+ (print "# Changed vars")
+ (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
+ (hash-table->alist changed)))))
+ ((csh)
+ (if a
+ (begin
+ (print "# Added vars")
+ (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
+ (hash-table->alist added))))
+ (if r
+ (begin
+ (print "# Removed vars")
+ (map (lambda (dat)(print "unsetenv " (car dat)))
+ (hash-table->alist removed))))
+ (if c
+ (begin
+ (print "# Changed vars")
+ (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
+ (hash-table->alist changed)))))
+ ((config ini)
+ (if a
+ (begin
+ (print "# Added vars")
+ (map (lambda (dat)(print (car dat) " " (cdr dat)))
+ (hash-table->alist added))))
+ (if r
+ (begin
+ (print "# Removed vars")
+ (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
+ (hash-table->alist removed))))
+ (if c
+ (begin
+ (print "# Changed vars")
+ (map (lambda (dat)(print (car dat) " " (cdr dat)))
+ (hash-table->alist changed)))))
+ (else
+ (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]")))))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -89,10 +89,13 @@
(mutex-lock! *heartbeat-mutex*)
(set! *last-db-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
+ (send-response body: (http-transport:main-page)))
+ ((equal? (uri-path (request-uri (current-request)))
+ '(/ "json_api"))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ "runs"))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -124,16 +124,16 @@
(items (hash-table-ref/default tconfig "items" '()))
(itemstable (hash-table-ref/default tconfig "itemstable" '())))
(debug:print 5 "items: " items " itemstable: " itemstable)
(set! items (map (lambda (item)
(if (procedure? (cadr item))
- (list (car item)((cadr item)))
+ (list (car item)((cadr item))) ;; evaluate the proc
item))
items))
(set! itemstable (map (lambda (item)
(if (procedure? (cadr item))
- (list (car item)((cadr item)))
+ (list (car item)((cadr item))) ;; evaluate the proc
item))
itemstable))
(if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined"))
(if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined"))
(if (or (not (null? items))(not (null? itemstable)))
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)
@@ -245,11 +257,11 @@
(loop (+ count 1)))))
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
- (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
+ (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
(tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
(print "Killed by signal " signum ". Exiting")
@@ -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)))
@@ -295,11 +313,11 @@
(change-directory *toppath*)
;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
;; seems non-ideal but could well break stuff
;; BUG? BUG? BUG?
-
+
(let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
(for-each (lambda (section)
@@ -431,12 +449,24 @@
(if ezsteps
(let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
;; ezstep names need a full re-eval here.
(tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
- (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())))
- (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
+ (ezstepslst (if (hash-table? testconfig)
+ (hash-table-ref/default testconfig "ezsteps" '())
+ #f)))
+ (if testconfig
+ (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
+ (begin
+ (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 "))))
+ ;; 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)))
(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))
@@ -443,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
@@ -559,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
@@ -580,106 +615,135 @@
(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)))))))
-;; set up the very basics needed for doing anything here.
-(define (launch:setup-for-run #!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
- (begin
- (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
- (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
- (get-environment-variable "MT_TARGET") "/"
- (get-environment-variable "MT_RUNNAME") "/"
- ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (if (file-exists? alistconfig)
- (list (configf:read-alist alistconfig)
- (get-environment-variable "MT_RUN_AREA_HOME"))
- #f))
- #f) ;; no config cached - give up
- (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))
- (if runname (setenv "MT_RUNNAME" runname))
- (find-and-read-config
- (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
- environ-patt: "env-override"
- given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
- pathenvvar: "MT_RUN_AREA_HOME"))))
- (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f))
- (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f))
- (let* ((tmptransport (configf:lookup *configdat* "server" "transport"))
- (transport (if tmptransport (string->symbol tmptransport) 'http)))
- (if (member transport '(http rpc nmsg))
- (set! *transport-type* transport)
- (begin
- (debug:print 0 "ERROR: Unrecognised transport " transport)
- (exit))))
- (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
- (if linktree
- (if (not (file-exists? linktree))
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- (create-directory linktree #t))))
- (begin
- (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
- (exit 1)))
- (if linktree
- (let ((dbdir (conc linktree "/.db")))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
- (if (not (directory-exists? dbdir))(create-directory dbdir)))
- (setenv "MT_LINKTREE" linktree))
- (begin
- (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
- (exit 1)))
- (if (and *toppath*
- (directory-exists? *toppath*))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (begin
- (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
- (exit 1)))
- )))
- *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")))
- (let* ((linktree (get-environment-variable "MT_LINKTREE"))
- (target (common:args-get-target))
- (runname (or (args:get-arg "-runname")
- (args:get-arg ":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)))
- (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* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
+ (runname (common:args-get-runname))
+ (target (common:args-get-target))
+ (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)))
+ (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 (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")))
@@ -687,12 +751,12 @@
(if disks
(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
(if res
(cdr res)
(begin
- (if (common:low-noise-print 20 "no valid disks")
- (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!"))
+ (if (common:low-noise-print 20 "No valid disks or no disk with enough space")
+ (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
(exit 1)))))))
;; Desired directory structure:
;;
;; <linkdir> - <target> - <testname> -.
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -233,10 +233,11 @@
"-port"
"-extract-ods"
"-pathmod"
"-env2file"
"-envcap"
+ "-envdelta"
"-setvars"
"-set-state-status"
"-set-run-status"
"-debug" ;; for *verbosity* > 2
"-gen-megatest-test"
@@ -312,14 +313,18 @@
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
+;; Add args that use remargs here
+;;
(if (and (not (null? remargs))
(not (or
- (args:get-arg "-runstep"))
- ;; add more args that use remargs here
+ (args:get-arg "-runstep")
+ (args:get-arg "-envcap")
+ (args:get-arg "-envdelta")
+ )
))
(debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
@@ -463,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
@@ -662,10 +667,53 @@
;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
;; (case (server:get-transport)
;; ((http)(http:ping run-id host-port))
;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port)))
;; (else (debug:print 0 "ERROR: No transport set")(exit)))))
+
+;;======================================================================
+;; Capture, save and manipulate environments
+;;======================================================================
+
+;; NOTE: Keep these above the section where the server or client code is setup
+
+(let ((envcap (args:get-arg "-envcap")))
+ (if envcap
+ (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
+ (env:save-env-vars db envcap)
+ (env:close-database db)
+ (set! *didsomething* #t))))
+
+;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b
+;;
+(let ((envdelta (args:get-arg "-envdelta")))
+ (if envdelta
+ (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
+ (if (not (null? match))
+ (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
+ ;; (resctx (cadr match))
+ ;; (equn (caddr match))
+ (parts match) ;; (string-split equn "-"))
+ (minuend (car parts))
+ (subtraend (cadr parts))
+ (added (env:get-added db minuend subtraend))
+ (removed (env:get-removed db minuend subtraend))
+ (changed (env:get-changed db minuend subtraend)))
+ ;; (pp (hash-table->alist added))
+ ;; (pp (hash-table->alist removed))
+ ;; (pp (hash-table->alist changed))
+ (if (args:get-arg "-o")
+ (with-output-to-file
+ (args:get-arg "-o")
+ (lambda ()
+ (env:print added removed changed)))
+ (env:print added removed changed))
+ (env:close-database db)
+ (set! *didsomething* #t))
+ (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end")))))
+
+
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
@@ -672,51 +720,51 @@
(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)
(set! *didsomething* #t))
- (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))))
+ (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
- ;; (if (null? (lset-intersection
- ;; equal?
- ;; (hash-table-keys args:arg-hash)
- ;; '("-list-servers"
- ;; "-stop-server"
- ;; "-show-cmdinfo"
- ;; "-list-runs"
- ;; "-ping")))
- ;; (if (launch:setup-for-run)
- ;; (let ((run-id (and (args:get-arg "-run-id")
- ;; (string->number (args:get-arg "-run-id")))))
- ;; ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
- ;; ;; if not list or kill then start a client (if appropriate)
- ;; (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
- ;; (eq? (length (hash-table-keys args:arg-hash)) 0))
- ;; (debug:print-info 1 "Server connection not needed")
- ;; (begin
- ;; ;; (if run-id
- ;; ;; (client:launch run-id)
- ;; ;; (client:launch 0) ;; without run-id we'll start a server for "0"
- ;; #t
- ;; ))))))
+ (if (null? (lset-intersection
+ equal?
+ (hash-table-keys args:arg-hash)
+ '("-list-servers"
+ "-stop-server"
+ "-show-cmdinfo"
+ "-list-runs"
+ "-ping")))
+ (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")
+ (eq? (length (hash-table-keys args:arg-hash)) 0))
+ (debug:print-info 1 "Server connection not needed")
+ (begin
+ ;; (if run-id
+ ;; (client:launch run-id)
+ ;; (client:launch 0) ;; without run-id we'll start a server for "0"
+ #t
+ ))))))
;; MAY STILL NEED THIS
;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(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 '())
@@ -779,27 +827,50 @@
(json-write targets))
(else
(debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(set! *didsomething* #t)))
+;; get the runconfigs
+;;
(define (full-runconfigs-read)
- (let* ((keys (rmt:get-keys))
- (target (common:args-get-target))
- (key-vals (if target (keys:target->keyval keys target) #f))
- (sections (if target (list "default" target) #f))
- (data (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (if key-vals
- (for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
- key-vals))
- (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
- data))
-
+ (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
+;; (file-exists? cfgf)
+;; (file-write-access? cfgf))
+;; (configf:read-alist cfgf)
+;; (let* ((keys (rmt:get-keys))
+;; (target (common:args-get-target))
+;; (key-vals (if target (keys:target->keyval keys target) #f))
+;; (sections (if target (list "default" target) #f))
+;; (data (begin
+;; (setenv "MT_RUN_AREA_HOME" *toppath*)
+;; (if key-vals
+;; (for-each (lambda (kt)
+;; (setenv (car kt) (cadr kt)))
+;; key-vals))
+;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
+;; (if (and rundir ;; have all needed variabless
+;; (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 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")
@@ -817,11 +888,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")
@@ -954,11 +1025,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")
@@ -1285,11 +1356,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)))
@@ -1443,11 +1514,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
@@ -1549,11 +1620,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)
@@ -1597,11 +1668,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))
@@ -1702,11 +1773,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 ", "))
@@ -1733,21 +1804,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)
@@ -1762,11 +1833,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)))
@@ -1775,11 +1846,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
@@ -1790,44 +1861,59 @@
;; Start a repl
;;======================================================================
;; fakeout readline
-(if (or (args:get-arg "-repl")
+(if (or (getenv "MT_RUNSCRIPT")
+ (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)
- (import extras) ;; might not be needed
- ;; (import csi)
- (import readline)
- (import apropos)
- ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
- (include "readline-fix.scm")
- (gnu-history-install-file-manager
- (string-append
- (or (get-environment-variable "HOME") ".") "/.megatest_history"))
- (current-input-port (make-gnu-readline-port "megatest> "))
- (if (args:get-arg "-repl")
- (repl)
- (load (args:get-arg "-load")))
- (db:close-all dbstruct))
- (exit))
- (set! *didsomething* #t)))
+ (cond
+ ((getenv "MT_RUNSCRIPT")
+ ;; How to run megatest scripts
+ ;;
+ ;; #!/bin/bash
+ ;;
+ ;; export MT_RUNSCRIPT=yes
+ ;; megatest << EOF
+ ;; (print "Hello world")
+ ;; (exit)
+ ;; EOF
+
+ (repl))
+ (else
+ (begin
+ (set! *db* dbstruct)
+ (set! *client-non-blocking-mode* #t)
+ (import extras) ;; might not be needed
+ ;; (import csi)
+ (import readline)
+ (import apropos)
+ ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
+ (include "readline-fix.scm")
+ (gnu-history-install-file-manager
+ (string-append
+ (or (get-environment-variable "HOME") ".") "/.megatest_history"))
+ (current-input-port (make-gnu-readline-port "megatest> "))
+ (if (args:get-arg "-repl")
+ (repl)
+ (load (args:get-arg "-load")))
+ (db:close-all dbstruct))
+ (exit)))
+ (set! *didsomething* #t))))
;;======================================================================
;; Wait on a run to complete
;;======================================================================
(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)))
@@ -1879,28 +1965,10 @@
#f ;; do all run-ids
'new2old
)
(set! *didsomething* #t)))
-;;======================================================================
-;; Capture, save and manipulate environments
-;;======================================================================
-
-(let ((envcap (args:get-arg "-envcap")))
- (if envcap
- (if (substring-index "=" envcap)
- (let* ((parts (string-split envcap "="))
- (fname (car parts))
- (context (cadr parts))
- (db (env:open-db fname)))
- (env:save-env-vars db context)
- (env:close-database db)
- (set! *didsomething* #t))
- (begin
- (debug:print 0 "ERROR: Parameter to -envcap should be <filename>=<context>. E.G. envdat=original, got: " envcap)
- (set! *didsomething* #t)))))
-
;;======================================================================
;; Exit and clean up
;;======================================================================
(if *runremote* (close-all-connections!))
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: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -583,10 +583,16 @@
(rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))))
(define (rmt:get-main-run-stats run-id)
(rmt:send-receive 'get-main-run-stats #f (list run-id)))
+(define (rmt:get-var varname)
+ (rmt:send-receive 'get-var #f (list varname)))
+
+(define (rmt:set-var varname value)
+ (rmt:send-receive 'set-var #f (list varname value)))
+
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
;; Need to move this to multi-run section and make associated changes
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -33,70 +33,10 @@
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
-;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
-;;
-;; NOT YET UTILIZED
-;;
-(define (runs:create-run-record)
- (let* ((mconfig (if *configdat*
- *configdat*
- (if (launch:setup-for-run)
- *configdat*
- (begin
- (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
- (exit 1)))))
- (runrec (runs:runrec-make-record))
- (target (common:args-get-target))
- (runname (common:args-get-runname))
- (testpatt (common:args-get-testpatt #f))
- (keys (keys:config-get-fields mconfig))
- (keyvals (keys:target->keyval keys target))
- (toppath *toppath*)
- (envdat keyvals) ;; initial values start with keyvals
- (runconfig #f)
- (serverdat (if (args:get-arg "-server")
- *runremote*
- #f)) ;; to be used later
- (transport (or (args:get-arg "-transport") 'http))
- (run-id #f))
- ;; Set all the environment vars we know so far, start with keys
- (for-each (lambda (keyval)
- (setenv (car keyval)(cadr keyval)))
- keyvals)
- ;; Set up various and sundry known vars here
- (setenv "MT_RUN_AREA_HOME" toppath)
- (setenv "MT_RUNNAME" runname)
- (setenv "MT_TARGET" target)
- (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))
- (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
- ;;
- (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)))
- ;; Now have runconfigs data loaded, set environment vars
-
- ;; Only now can we calculate the testpatt
- (set! testpatt (common:args-get-testpatt runconfig))
-
- (for-each (lambda (section)
- (for-each (lambda (varval)
- (set! envdat (append envdat (list varval)))
- (safe-setenv (car varval)(cadr varval)))
- (configf:get-section runconfig section)))
- (list "default" target))
- (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
(let* ((target (or intarget
(common:args-get-target)
(get-environment-variable "MT_TARGET")))
@@ -226,38 +166,40 @@
;; 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
+ ;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
- (test-names #f) ;; (tests:filter-test-names all-test-names test-patts))
+ (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
(required-tests #f) ;; Put fully qualified test/testpath names in this list to be done
(task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
(tdbdat (tasks:open-db))
(config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f))))
+ ;; per user request. If less than 100Meg space on dbdir partition, bail out with error
+ ;; this will reduce issues in database corruption
+ (common:check-db-dir-and-exit-if-insufficient)
+
;; override the number of reruns from the configs
(if (and config-reruns
(> run-count config-reruns))
(set! run-count config-reruns))
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(let ((sighand (lambda (signum)
- ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
- (if (eq? signum signal/stop)
- (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
+ y ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
(let ((tdbdat (tasks:open-db)))
(rmt:tasks-set-state-given-param-key task-key "killed"))
@@ -270,12 +212,11 @@
(exit 4)))))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2)))))
(set-signal-handler! signal/int sighand)
- (set-signal-handler! signal/term sighand)
- (set-signal-handler! signal/stop sighand))
+ (set-signal-handler! signal/term sighand))
(runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(set! runconf (if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(begin
@@ -288,11 +229,11 @@
(if (not test-patts) ;; first time in - adjust testpatt
(set! test-patts (common:args-get-testpatt runconf)))
;; Now generate all the tests lists
- (set! all-tests-registry (tests:get-all))
+ (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test
(set! all-test-names (hash-table-keys all-tests-registry))
(set! test-names (tests:filter-test-names all-test-names test-patts))
;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up.
@@ -345,11 +286,11 @@
;; What happended, this code is now duplicated in tests!?
;;
;;======================================================================
(if (not (null? test-names))
- (let loop ((hed (car test-names))
+ (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
(debug:print-info 8 "waitons: " waitons)
@@ -367,34 +308,11 @@
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority") ;; priority 3
- (let ((items (hash-table-ref/default config "items" #f)) ;; items 4
- (itemstable (hash-table-ref/default config "itemstable" #f)))
- ;; if either items or items table is a proc return it so test running
- ;; process can know to call items:get-items-from-config
- ;; if either is a list and none is a proc go ahead and call get-items
- ;; otherwise return #f - this is not an iterated test
- (cond
- ((procedure? items)
- (debug:print-info 4 "items is a procedure, will calc later")
- items) ;; calc later
- ((procedure? itemstable)
- (debug:print-info 4 "itemstable is a procedure, will calc later")
- itemstable) ;; calc later
- ((filter (lambda (x)
- (let ((val (car x)))
- (if (procedure? val) val #f)))
- (append (if (list? items) items '())
- (if (list? itemstable) itemstable '())))
- 'have-procedure)
- ((or (list? items)(list? itemstable)) ;; calc now
- (debug:print-info 4 "items and itemstable are lists, calc now\n"
- " items: " items " itemstable: " itemstable)
- (items:get-items-from-config config))
- (else #f))) ;; not iterated
+ (tests:get-items config) ;; expand the [items] and or [itemstable] into explict items
#f ;; itemsdat 5
#f ;; spare - used for item-path
waitors ;;
)))
(for-each
@@ -403,11 +321,11 @@
(let* ((waiton-record (hash-table-ref/default test-records waiton #f))
(waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f))
(waiton-itemized (and waiton-tconfig
(or (hash-table-ref/default waiton-tconfig "items" #f)
(hash-table-ref/default waiton-tconfig "itemstable" #f))))
- (itemmaps (tests:get-itemmaps config));; (configf:lookup config "requirements" "itemmap"))
+ (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap"))
(new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps)))
(debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
;; is this satisfied by merely appending "/" to the waiton name added to the list?
@@ -1780,12 +1698,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)
- (launch:cache-config)
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
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
@@ -108,10 +108,39 @@
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
+
+;; return items given config
+;;
+(define (tests:get-items tconfig)
+ (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
+ (itemstable (hash-table-ref/default tconfig "itemstable" #f)))
+ ;; if either items or items table is a proc return it so test running
+ ;; process can know to call items:get-items-from-config
+ ;; if either is a list and none is a proc go ahead and call get-items
+ ;; otherwise return #f - this is not an iterated test
+ (cond
+ ((procedure? items)
+ (debug:print-info 4 "items is a procedure, will calc later")
+ items) ;; calc later
+ ((procedure? itemstable)
+ (debug:print-info 4 "itemstable is a procedure, will calc later")
+ itemstable) ;; calc later
+ ((filter (lambda (x)
+ (let ((val (car x)))
+ (if (procedure? val) val #f)))
+ (append (if (list? items) items '())
+ (if (list? itemstable) itemstable '())))
+ 'have-procedure)
+ ((or (list? items)(list? itemstable)) ;; calc now
+ (debug:print-info 4 "items and itemstable are lists, calc now\n"
+ " items: " items " itemstable: " itemstable)
+ (items:get-items-from-config tconfig))
+ (else #f)))) ;; not iterated
+
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs)))
@@ -124,11 +153,11 @@
(config-lookup config "requirements" "waitor")
"")))
(debug:print-info 8 "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons
(string-split (cond
- ((procedure? instr)
+ ((procedure? instr) ;; here
(let ((res (instr)))
(debug:print-info 8 "waiton procedure results in string " res " for test " test-name)
res))
((string? instr) instr)
(else
@@ -188,10 +217,12 @@
patts))))
(string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
(list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
patts-waiton)))
",")))
+
+
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
@@ -735,45 +766,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 +891,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) '())))
@@ -868,30 +911,33 @@
(lambda ()
(let ((res (read-lines)))
;; (delete-file temp-path)
res))))))
-(define (tests:write-dot-file test-records fname)
+(define (tests:write-dot-file test-records fname sizex sizey)
(if (file-write-access? (pathname-directory fname))
(with-output-to-file fname
(lambda ()
- (map print (tests:tests->dot test-records))))))
+ (map print (tests:tests->dot test-records sizex sizey))))))
-(define (tests:tests->dot test-records)
+(define (tests:tests->dot test-records sizex sizey)
(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 {"
+ (conc " size=\"" (or sizex 11) "," (or sizey 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 "\";"))
+ (list (conc " \"" hed "\" [shape=box];"))
(map (lambda (waiton)
- (conc " \"" waiton "\" -> \"" hed "\";"))
+ (conc " \"" waiton "\" -> \"" hed "\" [shape=box];"))
waitons)
))))
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
@@ -912,14 +958,14 @@
res)))
;; read data from tmp file or create if not exists
;; if exists regen in background
;;
-(define (tests:lazy-dot testrecords outtype)
+(define (tests:lazy-dot testrecords outtype sizex sizey)
(let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
- (tests:write-dot-file testrecords dfile)
+ (tests:write-dot-file testrecords dfile sizex sizey)
(if (file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
(system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
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/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.