Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -9,11 +9,11 @@ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm \ client.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm \ + rmt.scm api.scm subrun.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = ftail.scm Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -13,11 +13,12 @@ format dot-locking csv-xml z3 ;; sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) - pkts) + pkts + ) (declare (unit common)) (include "common_records.scm") @@ -1779,10 +1780,30 @@ "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) + +(define (common:get-param-mapping #!key (flavor #f)) + "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" + (let ((default '(("tag-expr" . "-tagexpr") + ("mode-patt" . "-modepatt") + ("run-name" . "-runname") + ("contour" . "-contour") + ("mode-patt" . "-mode-patt") + ("target" . "-target") + ("test-patt" . "-testpatt") + ("msg" . "-m") + ("log" . "-log") + ("start-dir" . "-start-dir") + ("new" . "-set-state-status")))) + (if (eq? flavor 'switch-symbol) + (map (lambda (x) + (cons (string->symbol (conc "-" (car x))) (cdr x))) + default) + default))) + ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) ;; a value of #f means "unset this var" ;; (define (alist->env-vars lst) @@ -1797,10 +1818,11 @@ (safe-setenv var (->string val)) (unsetenv var)))) lst) res) '())) + ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; @@ -1823,10 +1845,11 @@ (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) + (define (common:run-a-command cmd #!key (with-vars #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) (fullcmd (if (or pre-cmd post-cmd) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -249,11 +249,11 @@ (subrun-tconf-file (conc test-run-dir "/testconfig.subrun")) (subrun-tconf (if (file-exists? subrun-tconf-file) (configf:read-alist subrun-tconf-file) (make-hash-table))) (subarea (or (configf:lookup testconfig "setup" "submegatest") - (configf:lookup subrun-tconf "subrun" "runarea"))) + (configf:lookup subrun-tconf "subrun" "run-area"))) (area-exists (and subarea (common:file-exists? subarea)))) ;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -18,10 +18,11 @@ (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) +(declare (uses subrun)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) (include "common_records.scm") @@ -293,11 +294,12 @@ (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if (or ezsteps subrun) - (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? + (let* ((test-run-dir (tests:get-test-path-from-environment)) + (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 item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) (hash-table-ref/default testconfig "ezsteps" '()) @@ -320,58 +322,18 @@ ;; 3. fix target ;; 4. fix runname ;; 5. fix testpatt or calculate it from contour ;; 6. launch the run ;; 7. roll up the run result and or roll up the logpro processed result - (if (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested - (let* ((runarea (let ((ra (configf:lookup testconfig "subrun" "runarea"))) - (if ra ;; when runarea is not set we default to *toppath*. However - ra ;; we need to force the setting in the testconfig so it will - (begin ;; be preserved in the testconfig.subrun file - (configf:set-section-var testconfig "subrun" "runarea" *toppath*) - *toppath*)))) - (passfail (configf:lookup testconfig "subrun" "passfail")) - (target (or (configf:lookup testconfig "subrun" "target") (get-environment-variable "MT_TARGET"))) - (runname (or (configf:lookup testconfig "subrun" "runname")(get-environment-variable "MT_RUNNAME"))) - (contour (configf:lookup testconfig "subrun" "contour")) - (testpatt (configf:lookup testconfig "subrun" "testpatt")) - (mode-patt (configf:lookup testconfig "subrun" "mode-patt")) - (tag-expr (configf:lookup testconfig "subrun" "tag-expr")) - (run-wait (configf:lookup testconfig "subrun" "runwait")) - (logpro (configf:lookup testconfig "subrun" "logpro")) - (compact-stem (string-substitute "[/*]" "_" (conc target "-" runname "-" (or testpatt mode-patt tag-expr)))) - (log-file (conc compact-stem ".log")) - (mt-cmd (conc "megatest -run -target " target - " -runname " runname - (conc " -start-dir " runarea) ;; (if runarea runarea *toppath*)) - (if testpatt (conc " -testpatt " testpatt) "") - (if mode-patt (conc " -modepatt " mode-patt) "") - (if tag-expr (conc " -tag-expr" tag-expr) "") - (if (equal? run-wait "yes") " -run-wait " "") - " -log " log-file))) - ;; change directory to runarea, create it if needed, we do NOT create the directory - ;; (if runarea - ;; (if (directory-exists? runarea) - ;; (change-directory runarea) - ;; (begin - ;; (debug:print 0 *default-log-port* "ERROR: for sub-megatest run the runarea \"" runarea "\" does not exist! EXITING.") - ;; (exit 1)))) - ;; (let ((subrun (conc *toppath* "/subrun") #t)) - ;; (create-directory subrun) - ;; (change-directory subrun))) - - ;; by this point we are in the right place to run the subrun and we have a Megatest command to run - ;; (filter (lambda (x)(string-match "MT_.*" (car x))) (get-environment-variables)) - ;; (common:without-vars mt-cmd "^MT_.*") + (when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested + (subrun:initialize-toprun-test testconfig test-run-dir) + (let* ((mt-cmd (subrun:launch-cmd test-run-dir))) (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"") (set! ezsteps #t) ;; set the needed flag - (set! ezstepslst (append (or ezstepslst '()) - (list (list "subrun" (conc "{subrun=true} " mt-cmd))))) - (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun - (if runarea (configf:set-section-var testconfig "setup" "submegatest" runarea)) - (configf:write-alist testconfig "testconfig.subrun") - )) + (set! ezstepslst + (append (or ezstepslst '()) + (list (list "subrun" (conc "{subrun=true} " mt-cmd))))))) ;; process the ezsteps (if ezsteps (begin (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -253,19 +253,14 @@ ;; U T I L S ;;====================================================================== ;; given a mtutil param, return the old megatest equivalent ;; -(define (param-translate param) - (or (alist-ref (string->symbol param) - '((-tag-expr . "-tagexpr") - (-mode-patt . "-modepatt") - (-run-name . "-runname") - (-test-patt . "-testpatt") - (-msg . "-m") - (-new . "-set-state-status"))) - param)) +(define (megatest-param->mtutil-param param) + (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol))) + (alist-ref (string->symbol param) mapping-alist eq? param) + param)) (define (val->alist val) (let ((val-list (string-split-fields ";\\s*" val #:infix))) (if val-list (map (lambda (x) @@ -963,22 +958,23 @@ ;; (print "res=" res) res)))) (hash-table-keys torun))))))) (define (pkt->cmdline pkta) - (let* ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction")) - (action-param (case (string->symbol action) - ((-set-state-status) (conc (alist-ref 'l pkta) " ")) - (else "")))) + (let* ((param-mapping-alist (common:get-param-mapping flavor: 'switch-symbol)) + (action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction")) + (action-param (case (string->symbol action) + ((-set-state-status) (conc (alist-ref 'l pkta) " ")) + (else "")))) (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (or (lookup-param-by-key key) ;; need to check also if it is a switch (lookup-param-by-key key inlst: *switch-keys*)))) ;; (print "key: " key " val: " val " par: " par) (if par - (conc res " " (param-translate par) " " val) + (conc res " " (alist-ref (string->symbol par) param-mapping-alist eq? par) " " val) (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches res (begin (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") res))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1150,19 +1150,19 @@ (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) - ;; ELSE: can't drop this - maybe running? Just keep trying + ;; ELSE: can't drop this - maybe running? Just keep trying ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met? (if (null? runable-tests) #f ;; I think we are truly done here (runs:loop-values newtal reg reglen regfull reruns))) ;;) ;;from old experiment - ) ;; end if (or (not (null? reg))(not (null? tal))) + ) ;; end if (or (not (null? reg))(not (null? tal))) )))))) ;; scan a list of tests looking to see if any are potentially runnable ;; (define (runs:runable-tests tests) @@ -1192,11 +1192,11 @@ inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path run-info: #f runname: #f target: #f ) -) + ) (define (runs:incremental-print-results run-id) (let ((curr-sec (current-seconds))) (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id))) @@ -1380,11 +1380,11 @@ ;; (server:ping (remote-server-url *runremote*))) ;; (server:check-if-running *toppath*)))) ;; (server:kind-run *toppath*)) (if (> num-running 0) - (set! last-time-some-running (current-seconds))) + (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*)) @@ -1405,11 +1405,11 @@ (if (or (not (null? tal))(not (null? reg))) (loop (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) - ;; (loop (car tal)(cdr tal) reg reruns)))) + ;; (loop (car tal)(cdr tal) reg reruns)))) (runs:incremental-print-results run-id) (debug:print 4 *default-log-port* "TOP OF LOOP => " "test-name: " test-name "\n hed: " hed @@ -1462,11 +1462,11 @@ (not (null? tal))) (loop (car tal)(cdr tal) reg reruns)) (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (let ((loop-list (runs:process-expanded-tests runsdat testdat))) - (if loop-list (apply loop loop-list)))) + (if loop-list (apply loop loop-list)))) ;; items processed into a list but not came in as a list been processed ;; ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done @@ -1477,17 +1477,17 @@ (> (length items) 0) (and (list? (car items)) (> (length (car items)) 0)) (debug:debug-mode 1)) (debug:print 2 *default-log-port* (map (lambda (row) - (conc (string-intersperse - (map (lambda (varval) - (string-intersperse varval "=")) - row) - " ") - "\n")) - items))) + (conc (string-intersperse + (map (lambda (varval) + (string-intersperse varval "=")) + row) + " ") + "\n")) + items))) (let* ((items-in-testpatt (filter (lambda (my-itemdat) (tests:match test-patts hed (item-list->path my-itemdat) )) @@ -1505,27 +1505,27 @@ newrec)) (my-item-path (item-list->path my-itemdat)) (newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - (set! tal (append tal (list newtestname))))) ;; since these are itemized create new test names testname/itempath + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (tests:testqueue-set-item_path! new-test-record my-item-path) + (hash-table-set! test-records newtestname new-test-record) + (set! tal (append tal (list newtestname))))) ;; since these are itemized create new test names testname/itempath items-in-testpatt))) - - + + ;; At this point we have possibly added items to tal but all must be handed off to ;; INNER COND logic. I think loop without rotating the queue ;; (loop hed tal reg reruns)) ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test ;; (loop (car newtal)(cdr newtal) reg reruns) (if (null? tal) #f (loop (car tal)(cdr tal) reg reruns))) - + ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-4") @@ -1538,11 +1538,11 @@ (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) ) ) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) - + ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) (debug:print-info 4 *default-log-port* "cond branch - " "rtq-5") (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this") (exit 1)) @@ -1684,12 +1684,12 @@ ;; per-test call is not needed. Given the delicacy of the move to ;; v1.55 this code is being left in place for the time being. ;; (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin - (hash-table-set! *test-meta-updated* test-name #t) - (runs:update-test_meta test-name test-conf))) + (hash-table-set! *test-meta-updated* test-name #t) + (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (rmt:get-test-id run-id test-name item-path)) (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) @@ -1929,11 +1929,11 @@ ((remove-runs) (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))) ((archive) (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))))) actions)))) - sorted))) + sorted))) ;; (print "Sorted: " (map simple-run-event_time sorted)) ;; (print "Remove: " (map simple-run-event_time to-remove)))) (hash-table-keys runs-ht)) runs-ht)) @@ -1988,16 +1988,16 @@ (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) (db:get-value-by-header run header k)) keys) "/")) (dirs-to-remove (make-hash-table)) (proc-get-tests (lambda (run-id) - (mt:get-tests-for-run run-id - testpatt states statuses - not-in: #f - sort-by: (case action - ((remove-runs) 'rundir) - (else 'event_time)))))) + (mt:get-tests-for-run run-id + testpatt states statuses + not-in: #f + sort-by: (case action + ((remove-runs) 'rundir) + (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (run-name (db:get-value-by-header run header "runname")) (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) @@ -2072,46 +2072,46 @@ (toplevel-with-children (and (db:test-get-is-toplevel test) (> (rmt:test-toplevel-num-items run-id test-name) 0)))) (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove - (if toplevel-with-children - (begin - (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") - (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) - (if (> (hash-table-ref toplevel-retries test-fulln) 3) - (if (not (null? tal)) - (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries - (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue - (begin - (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state) - (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) - (begin - (if (not (hash-table-ref/default test-retry-time test-fulln #f)) - (begin - ;; want to set to REMOVING BUT CANNOT do it here? - (hash-table-set! test-retry-time test-fulln (current-seconds)))) - (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) - ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first - ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give - ;; up and blow it away. - (begin - (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) - (thread-sleep! 1)) - (begin - (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) - (thread-sleep! 1))) - ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... - (if (null? tal) - (loop new-test-dat tal) - (loop (car tal)(append tal (list new-test-dat))))) - (begin - (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) - (if (not (null? tal)) - (loop (car tal)(cdr tal))))))) + (cond + (toplevel-with-children + (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) + (if (> (hash-table-ref toplevel-retries test-fulln) 3) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue + (else + (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state) + (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (begin + (if (not (hash-table-ref/default test-retry-time test-fulln #f)) + (begin + ;; want to set to REMOVING BUT CANNOT do it here? + (hash-table-set! test-retry-time test-fulln (current-seconds)))) + (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) + ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first + ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give + ;; up and blow it away. + (begin + (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (thread-sleep! 1)) + (begin + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (thread-sleep! 1))) + ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... + (if (null? tal) + (loop new-test-dat tal) + (loop (car tal)(append tal (list new-test-dat))))) + (begin + (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ((set-state-status) (debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) ADDED subrun.scm Index: subrun.scm ================================================================== --- /dev/null +++ subrun.scm @@ -0,0 +1,151 @@ + +;; Copyright 2006-2016, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) + posix-extras directory-utils pathname-expand typed-records format) +(declare (unit subrun)) +;;(declare (uses runs)) +;;(declare (uses db)) +(declare (uses common)) +;;(declare (uses items)) +;;(declare (uses runconfig)) +;;(declare (uses tests)) +;;(declare (uses server)) +;;(declare (uses mt)) +;;(declare (uses archive)) +;; (declare (uses filedb)) + +;(include "common_records.scm") +;;(include "key_records.scm") +;;(include "db_records.scm") +;;(include "run_records.scm") +;;(include "test_records.scm") + + +(define (subrun:initialize-toprun-test testconfig test-run-dir) + + (let ((ra (configf:lookup testconfig "subrun" "run-area")) + (logpro (configf:lookup testconfig "subrun" "logpro")) + (symlink-target (conc test-run-dir "/subrun-area")) + ) + (when (not ra) ;; when runarea is not set we default to *toppath*. However + ;; we need to force the setting in the testconfig so it will + ;; be preserved in the testconfig.subrun file + (configf:set-section-var testconfig "subrun" "runarea" *toppath*)) + (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun + + (if (common:file-exists? symlink-target) + (delete-file symlink-target)) + + (create-symbolic-link ra symlink-target) + + (configf:write-alist testconfig "testconfig.subrun"))) + + +(define (subrun:launch-cmd test-run-dir) + (let* ((log-prefix "run") + (switches (subrun:selector+log-switches test-run-dir log-prefix)) + (run-wait #t) + (cmd (conc "megatest -run "switches" " + (if run-wait "-run-wait " "")))) + cmd)) + +;; set state/status of test item +;; fork off megatest +;; set state/status of test item +;; + + +(define (subrun:selector+log-switches test-run-dir log-prefix) + (let* ((switch-def-alist (common:get-param-mapping flavor: 'config)) + (subrunfile (conc test-run-dir "/testconfig.subrun" )) + (subrundata (with-input-from-file subrunfile read)) + (subrunconfig (configf:alist->config subrundata)) + (run-area (configf:lookup subrunconfig "subrun" "run-area")) + (defvals `(("start-dir" . ,(or run-area ;; default values if not specified in subrun section of tconf + (get-environment-variable "MT_RUN_AREA_HOME") + "/no/rundir/found")) + ("run-name" . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME")) + ("target" . ,(or (get-environment-variable "MT_TARGET") "NO-TARGET")))) + (switch-alist-pre (filter-map (lambda (item) + (let* ((config-key (car item)) + (switch (cdr item)) + (defval (alist-ref config-key defvals equal? #f)) + (val (or (configf:lookup subrunconfig "subrun" config-key) + defval))) + (if val + (cons switch val) + #f))) + switch-def-alist)) + + ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null + (mode-patt (alist-ref "-modepatt" switch-alist-pre equal? #f)) + (tag-expr (alist-ref "-tagexpr" switch-alist-pre equal? #f)) + (testpatt (alist-ref "-testpatt" switch-alist-pre equal? + (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not + ;; otherwise specified + + ;; define compact-stem for logfile + (target (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref + (runname (alist-ref "-runname" switch-alist-pre equal? #f)) + + + (compact-stem (string-substitute "[/*]" "_" + (conc + target + "-" + runname + "-" (or testpatt mode-patt tag-expr "NO-TESTPATT")))) + (logfile (conc + test-run-dir "/" + (or log-prefix "") + (if log-prefix "-" "") + compact-stem + ".log")) + ;; swap out testpatt with modified test-patt and add -log + (switch-alist (cons + (cons "-log" logfile) + (map (lambda (item) + (if (equal? (car item) "-testpatt") + (cons "-testpatt" testpatt) + item)) + switch-alist-pre)))) + ;; note - get precmd from subrun section + ;; apply to submegatest commands + (let* ((res + (string-intersperse + (apply + append + (map + (lambda (x) + (list (car x) (cdr x))) + switch-alist)) + " "))) + res))) + + +(define (subrun:exec-sub-megatest test-run-dir switches #!key (logfile #f)) + (let* ((real-logfile (or logfile (conc (test-run-dir) "/subrun-" + (string-substitute "[/*]" "_" (string-intersperse switches "^"))"-" + (number->string (current-seconds)) ".log"))) + (selector-switches (common:sub-megatest-selector-switches test-run-dir)) + (cmd-list `("megatest" ,@selector-switches ,@switches "-log" ,real-logfile)) + ) + (call-with-environment-variables + (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) + (lambda () + (common:without-vars proc "^MT_.*") + + )))) + + +