Index: mtmod.scm
==================================================================
--- mtmod.scm
+++ mtmod.scm
@@ -21,11 +21,11 @@
(declare (unit mtmod))
;; (declare (uses mtargs))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbmod))
-;; (declare (uses rmtmod))
+(declare (uses configfmod))
(module mtmod
*
(import scheme
@@ -46,11 +46,11 @@
debugprint
;; mtargs
;; pkts
commonmod
dbmod
- ;; rmtmod
+ configfmod
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
@@ -121,8 +121,151 @@
(if (member failed-test waitons)
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
+
+;;======================================================================
+;; read a config file, loading only the section pertinent
+;; to this run field1val/field2val/field3val ...
+;;======================================================================
+
+;; (use format directory-utils)
+;;
+;; (declare (unit runconfig))
+;; (declare (uses common))
+;;
+;; (include "common_records.scm")
+
+;; NB// to process a runconfig ensure to use environ-patt with target!
+;;
+(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t))
+ (let* ((keys (map car keyvals))
+ (thekey (if keyvals
+ (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/")
+ (or (common:args-get-target)
+ (get-environment-variable "MT_TARGET")
+ (begin
+ (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg")
+ "nothing matches this I hope"))))
+ ;; Why was system disallowed in the reading of the runconfigs file?
+ ;; NOTE: Should be setting env vars based on (target|default)
+ (confdat (runconfig:read fname thekey environ-patt))
+ (whatfound (make-hash-table))
+ (finaldat (make-hash-table))
+ (sections (list "default" thekey)))
+ (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
+ (debug:print 4 *default-log-port* "Using key=\"" thekey "\"")
+
+ (if change-env
+ (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
+ (lambda (keyval)
+ (safe-setenv (car keyval)(cadr keyval)))
+ keyvals))
+
+ (for-each
+ (lambda (section)
+ (let ((section-dat (hash-table-ref/default confdat section #f)))
+ (if section-dat
+ (for-each
+ (lambda (envvar)
+ (let ((val (cadr (assoc envvar section-dat))))
+ (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
+ (if (and (string? envvar)
+ (string? val)
+ change-env)
+ (safe-setenv envvar val))
+ (hash-table-set! finaldat envvar val)))
+ (map car section-dat)))))
+ sections)
+ (if already-seen
+ (begin
+ (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:")
+ (for-each (lambda (fullkey)
+ (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
+ sections)
+ (debug:print 2 *default-log-port* "---")
+ (set! *already-seen-runconfig-info* #t)))
+ ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses
+ confdat
+ ))
+
+(define (set-run-config-vars run-id keyvals targ-from-db)
+ (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ...
+ (let ((runconfigf (conc *toppath* "/runconfigs.config"))
+ (targ (or (common:args-get-target)
+ targ-from-db
+ (get-environment-variable "MT_TARGET"))))
+ (pop-directory)
+ (if (common:file-exists? runconfigf)
+ (setup-env-defaults runconfigf run-id #t keyvals
+ environ-patt: (conc "(default"
+ (if targ
+ (conc "|" targ ")")
+ ")")))
+ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf))))
+
+;; given (a (b c) d) return ((a b d)(a c d))
+;; NOTE: this feels like it has been done before - perhaps with items handling?
+;;
+(define (runconfig:combinations inlst)
+ (let loop ((hed (car inlst))
+ (tal (cdr inlst))
+ (res '()))
+ ;; (print "res: " res " hed: " hed)
+ (if (list? hed)
+ (let ((newres (if (null? res) ;; first time through convert incoming items to list of items
+ (map list hed)
+ (apply append
+ (map (lambda (r) ;; iterate over items in res
+ (map (lambda (h) ;; iterate over items in hed
+ (append r (list h)))
+ hed))
+ res)))))
+ ;; (print "newres1: " newres)
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))
+ (let ((newres (if (null? res)
+ (list (list hed))
+ (map (lambda (r)
+ (append r (list hed)))
+ res))))
+ ;; (print "newres2: " newres)
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+;; multi-part expand
+;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f
+;;
+(define (runconfig:expand target)
+ (let* ((parts (map (lambda (x)
+ (string-split x ","))
+ (string-split target "/"))))
+ (map (lambda (x)
+ (string-intersperse x "/"))
+ (runconfig:combinations parts))))
+
+;; multi-target expansion
+;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y
+;;
+(define (runconfig:expand-target target-strs)
+ (delete-duplicates
+ (apply append (map runconfig:expand (string-split target-strs " ")))))
+
+#|
+ (if (null? target-strs)
+ '()
+ (let loop ((hed (car target-strs))
+ (tal (cdr target-strs))
+ (res '()))
+ ;; first break all parts into individual target patterns
+ (if (string-index hed " ") ;; this is a multi-target target
+ (let ((newres (append (string-split hed " ") res)))
+ (runconfig:expand-target newres))
+ (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated
+
+|#
)
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -13,147 +13,5 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
-;;======================================================================
-;; read a config file, loading only the section pertinent
-;; to this run field1val/field2val/field3val ...
-;;======================================================================
-
-;; (use format directory-utils)
-;;
-;; (declare (unit runconfig))
-;; (declare (uses common))
-;;
-;; (include "common_records.scm")
-
-;; NB// to process a runconfig ensure to use environ-patt with target!
-;;
-(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t))
- (let* ((keys (map car keyvals))
- (thekey (if keyvals
- (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/")
- (or (common:args-get-target)
- (get-environment-variable "MT_TARGET")
- (begin
- (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg")
- "nothing matches this I hope"))))
- ;; Why was system disallowed in the reading of the runconfigs file?
- ;; NOTE: Should be setting env vars based on (target|default)
- (confdat (runconfig:read fname thekey environ-patt))
- (whatfound (make-hash-table))
- (finaldat (make-hash-table))
- (sections (list "default" thekey)))
- (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
- (debug:print 4 *default-log-port* "Using key=\"" thekey "\"")
-
- (if change-env
- (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
- (lambda (keyval)
- (safe-setenv (car keyval)(cadr keyval)))
- keyvals))
-
- (for-each
- (lambda (section)
- (let ((section-dat (hash-table-ref/default confdat section #f)))
- (if section-dat
- (for-each
- (lambda (envvar)
- (let ((val (cadr (assoc envvar section-dat))))
- (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
- (if (and (string? envvar)
- (string? val)
- change-env)
- (safe-setenv envvar val))
- (hash-table-set! finaldat envvar val)))
- (map car section-dat)))))
- sections)
- (if already-seen
- (begin
- (debug:print 2 *default-log-port* "Key settings found in runconfigs.config:")
- (for-each (lambda (fullkey)
- (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
- sections)
- (debug:print 2 *default-log-port* "---")
- (set! *already-seen-runconfig-info* #t)))
- ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses
- confdat
- ))
-
-(define (set-run-config-vars run-id keyvals targ-from-db)
- (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ...
- (let ((runconfigf (conc *toppath* "/runconfigs.config"))
- (targ (or (common:args-get-target)
- targ-from-db
- (get-environment-variable "MT_TARGET"))))
- (pop-directory)
- (if (common:file-exists? runconfigf)
- (setup-env-defaults runconfigf run-id #t keyvals
- environ-patt: (conc "(default"
- (if targ
- (conc "|" targ ")")
- ")")))
- (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf))))
-
-;; given (a (b c) d) return ((a b d)(a c d))
-;; NOTE: this feels like it has been done before - perhaps with items handling?
-;;
-(define (runconfig:combinations inlst)
- (let loop ((hed (car inlst))
- (tal (cdr inlst))
- (res '()))
- ;; (print "res: " res " hed: " hed)
- (if (list? hed)
- (let ((newres (if (null? res) ;; first time through convert incoming items to list of items
- (map list hed)
- (apply append
- (map (lambda (r) ;; iterate over items in res
- (map (lambda (h) ;; iterate over items in hed
- (append r (list h)))
- hed))
- res)))))
- ;; (print "newres1: " newres)
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres)))
- (let ((newres (if (null? res)
- (list (list hed))
- (map (lambda (r)
- (append r (list hed)))
- res))))
- ;; (print "newres2: " newres)
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres))))))
-
-;; multi-part expand
-;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f
-;;
-(define (runconfig:expand target)
- (let* ((parts (map (lambda (x)
- (string-split x ","))
- (string-split target "/"))))
- (map (lambda (x)
- (string-intersperse x "/"))
- (runconfig:combinations parts))))
-
-;; multi-target expansion
-;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y
-;;
-(define (runconfig:expand-target target-strs)
- (delete-duplicates
- (apply append (map runconfig:expand (string-split target-strs " ")))))
-
-#|
- (if (null? target-strs)
- '()
- (let loop ((hed (car target-strs))
- (tal (cdr target-strs))
- (res '()))
- ;; first break all parts into individual target patterns
- (if (string-index hed " ") ;; this is a multi-target target
- (let ((newres (append (string-split hed " ") res)))
- (runconfig:expand-target newres))
- (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated
-
-|#
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -17,10 +17,11 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit runsmod))
+
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses mtargs))
(declare (uses mtver))
@@ -33,10 +34,12 @@
(declare (uses testsmod))
(declare (uses tasksmod))
(declare (uses archivemod))
(declare (uses launchmod))
(declare (uses subrunmod))
+(declare (uses servermod))
+(declare (uses itemsmod))
(module runsmod
*
(import scheme
@@ -89,14 +92,19 @@
testsmod
tasksmod
archivemod
launchmod
subrunmod
+ servermod
+ itemsmod
)
(include "db_records.scm")
+(include "run_records.scm")
+(include "test_records.scm")
+(include "key_records.scm")
;; use this struct to facilitate refactoring
;;
(defstruct runs:dat
@@ -2053,11 +2061,11 @@
;;
;; This will fail if called with empty target or a bad target (i.e. missing or extra fields)
;;
(define (runs:get-hash-by-target target-patts runpatt)
(let* ((targets (string-split target-patts ","))
- (keys (common:get-fields *configfdat*)) ;; (rmt:get-keys))
+ (keys (rmt:get-keys))
(res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
(for-each
(lambda (target-patt)
(let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f)))
(for-each
@@ -2133,11 +2141,11 @@
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '()))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
;; (tdbdat (tasks:open-db))
- (keys (common:get-fields *configdat*)) ;; (rmt:get-keys))
+ (keys (rmt:get-keys))
(rundat (mt:get-runs-by-patt keys runnamepatt target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -17,54 +17,10 @@
;; along with Megatest. If not, see .
;;
;;======================================================================
-;; for each test:
-;;
-(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
- (let ((runnables '()))
- (for-each
- (lambda (testkeyname)
- (let* ((test-record (hash-table-ref testrecordshash testkeyname))
- (test-name (tests:testqueue-get-testname test-record))
- (itemdat (tests:testqueue-get-itemdat test-record))
- (item-path (tests:testqueue-get-item_path test-record))
- (waitons (tests:testqueue-get-waitons test-record))
- (keep-test #t)
- (test-id (rmt:get-test-id run-id test-name item-path))
- (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
- (if tdat
- (begin
- ;; Look at the test state and status
- (if (or (and (member (db:test-get-status tdat)
- '("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
- (equal? (db:test-get-state tdat) "COMPLETED"))
- (member (db:test-get-state tdat)
- '("INCOMPLETE" "KILLED")))
- (set! keep-test #f))
-
- ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
- ;; from the runnable list
- (if keep-test
- (for-each (lambda (waiton)
- ;; for now we are waiting only on the parent test
- (let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
- (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
- (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
- (member (db:test-get-status wtdat) '("FAIL" "ABORT")))
- (member (db:test-get-status wtdat) '("KILLED"))
- (member (db:test-get-state wtdat) '("INCOMPETE")))
- ;; (if (or (member (db:test-get-status wtdat)
- ;; '("FAIL" "KILLED"))
- ;; (member (db:test-get-state wtdat)
- ;; '("INCOMPETE")))
- (set! keep-test #f)))) ;; no point in running this one again
- waitons))))
- (if keep-test (set! runnables (cons testkeyname runnables)))))
- testkeynames)
- runnables))
;;======================================================================
;; html output from server
;;======================================================================
Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -1474,10 +1474,54 @@
(s:a 'href step-log step-log)))))
steps-dat))
)))
(close-output-port oup)))))
+;; for each test:
+;;
+(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
+ (let ((runnables '()))
+ (for-each
+ (lambda (testkeyname)
+ (let* ((test-record (hash-table-ref testrecordshash testkeyname))
+ (test-name (tests:testqueue-get-testname test-record))
+ (itemdat (tests:testqueue-get-itemdat test-record))
+ (item-path (tests:testqueue-get-item_path test-record))
+ (waitons (tests:testqueue-get-waitons test-record))
+ (keep-test #t)
+ (test-id (rmt:get-test-id run-id test-name item-path))
+ (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (if tdat
+ (begin
+ ;; Look at the test state and status
+ (if (or (and (member (db:test-get-status tdat)
+ '("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
+ (equal? (db:test-get-state tdat) "COMPLETED"))
+ (member (db:test-get-state tdat)
+ '("INCOMPLETE" "KILLED")))
+ (set! keep-test #f))
+
+ ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
+ ;; from the runnable list
+ (if keep-test
+ (for-each (lambda (waiton)
+ ;; for now we are waiting only on the parent test
+ (let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
+ (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
+ (member (db:test-get-status wtdat) '("FAIL" "ABORT")))
+ (member (db:test-get-status wtdat) '("KILLED"))
+ (member (db:test-get-state wtdat) '("INCOMPETE")))
+ ;; (if (or (member (db:test-get-status wtdat)
+ ;; '("FAIL" "KILLED"))
+ ;; (member (db:test-get-state wtdat)
+ ;; '("INCOMPETE")))
+ (set! keep-test #f)))) ;; no point in running this one again
+ waitons))))
+ (if keep-test (set! runnables (cons testkeyname runnables)))))
+ testkeynames)
+ runnables))
)