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: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -33,77 +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) - *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 -- can replace this with call to launch:setup? - ;; - ;; This block should be ok to remove - just keep the set of runconfig - ;; - (if (not (eq? *configstatus* 'fulldata)) - (begin - (debug:print 0 "Processing runconfigs.config again...") - (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) - (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) - (begin - (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) - (if db (sqlite3:finalize! db)) - (exit 1)))) - (set! runconfig *runconfigdat*)) - ;; Now have runconfigs data loaded, set environment vars - - ;; Only now can we calculate the testpatt - (set! testpatt (common:args-get-testpatt runconfig)) - - (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"))) @@ -237,17 +170,17 @@ ;; (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)))) @@ -259,12 +192,10 @@ (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.")) (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")) @@ -277,12 +208,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 @@ -295,11 +225,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. @@ -352,11 +282,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) @@ -374,34 +304,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 @@ -410,11 +317,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? 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))