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 @@ -91,10 +91,11 @@ runs.o \ server.o \ tasks.o \ tdb.o \ tests.o \ + subrun.o \ tcmt : $(TCMTOBJS) tcmt.scm csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -23,10 +23,12 @@ get-var get-keys get-key-vals test-toplevel-num-items get-test-info-by-id + get-steps-info-by-id + get-data-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record @@ -66,10 +68,11 @@ login tasks-get-last testmeta-get-record have-incompletes? synchash-get + get-changed-record-ids )) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -193,10 +193,23 @@ dbh "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;" test-id category variable)) (define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type) + ; (print "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) + ; VALUES (?,?,?,?,?,?,?,?,?,?) " test-id " " category " " variable " " value " " expected " " tol " " units " " comment " " status " " type) + (if (not (string? units)) + (set! units "" )) + (if (not (string? variable)) + (set! variable "" )) + (if (not (real? value)) + (set! value 0 )) + (if (not (real? expected)) + (set! expected 0 )) +(if (not (real? tol)) + (set! tol 0 )) + (dbi:exec dbh "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units comment status type)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -13,15 +13,17 @@ 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") + ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) @@ -801,16 +803,27 @@ (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) ;;(debug:print-info 13 *default-log-port* "got signal "signum) - (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") + (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(define (special-signal-handler signum) + ;; (signal-mask! signum) + (set! *time-to-exit* #t) + ;;(debug:print-info 13 *default-log-port* "got signal "signum) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!") + ;;TODO send email to notify admin contact listed in the config that the lisner got killed ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) + (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) + ;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== @@ -1768,10 +1781,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) @@ -1786,10 +1819,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. ;; @@ -1812,10 +1846,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) @@ -2473,16 +2508,19 @@ (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f) (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) (pktsdir (car pktsdirs))) ;; assume it is there (hash-table-set! *pkts-info* 'pkts-dir pktsdir) pktsdir)))) - (if (not (file-exists? pktsdir)) - (create-directory pktsdir #t)) - (with-output-to-file - (conc pktsdir "/" uuid ".pkt") - (lambda () - (print pkt)))))))) + (handle-exceptions + exn + (debug:print-info 0 "failed to write out packet to " pktsdir) ;; don't care if this failed for now but MUST FIX - BUG!! + (if (not (file-exists? pktsdir)) + (create-directory pktsdir #t)) + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt))))))))) (define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f)) (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) (pktsdir (if pktsdirs (car pktsdirs) #f)) (toppath (or (configf:lookup mtconf "scratchdat" "toppath") @@ -2591,5 +2629,11 @@ restore-thunk)) delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) + +(define (common:send-thunk-to-background-thread thunk #!key (name #f)) + ;;(BB> "launched thread " name) + (if name + (thread-start! (make-thread thunk name)) + (thread-start! (make-thread thunk)))) 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: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -1015,10 +1015,10 @@
Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -2209,14 +2209,14 @@ 
[subrun]
 
 # Required: wait for the run or just launch it
 #           if no then the run will be an automatic PASS irrespective of the actual result
-runwait yes|no
+run-wait yes|no
 
 # Optional: where to execute the run. Default is the current runarea
-runarea /some/path/to/megatest/area
+run-area /some/path/to/megatest/area
 
 # Optional: method to use to determine pass/fail status of the run
 #   auto (default) - roll up the net state/status of the sub-run
 #   logpro         - use the provided logpro rules, happens automatically if there is a logpro section
 # passfail auto|logpro
@@ -2230,14 +2230,14 @@
 
 # Optional: target translator, default is to use the parent target
 target #{shell somescript.sh}
 
 # Optional: runname translator/generator, default is to use the parent runname
-runname #{somescript.sh}
+run-name #{somescript.sh}
 
 # Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
-testpatt %/item1,test2
+test-patt %/item1,test2
 
 # Optional: contour spec, use the named contour from the megatest.config contour spec
 contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
 
 # Optional: mode-patt, use this spec for testpatt from runconfigs
@@ -2244,11 +2244,11 @@
 mode-patt TESTPATT
 
 # Optional: tag-expr, use this tag-expr to select tests
 tag-expr quick
 
-# Optional: (not yet implemented), propagate these actions from the parent
+# Optional: (not yet implemented, remove-runs is always propagated at this time), propagate these actions from the parent
 #           test
 #   Note// default is % for all
 propagate remove-runs archive ...
@@ -2311,10 +2311,10 @@
Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -714,14 +714,14 @@ --------------- [subrun] # Required: wait for the run or just launch it # if no then the run will be an automatic PASS irrespective of the actual result -runwait yes|no +run-wait yes|no # Optional: where to execute the run. Default is the current runarea -runarea /some/path/to/megatest/area +run-area /some/path/to/megatest/area # Optional: method to use to determine pass/fail status of the run # auto (default) - roll up the net state/status of the sub-run # logpro - use the provided logpro rules, happens automatically if there is a logpro section # passfail auto|logpro @@ -735,14 +735,14 @@ # Optional: target translator, default is to use the parent target target #{shell somescript.sh} # Optional: runname translator/generator, default is to use the parent runname -runname #{somescript.sh} +run-name #{somescript.sh} # Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec -testpatt %/item1,test2 +test-patt %/item1,test2 # Optional: contour spec, use the named contour from the megatest.config contour spec contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature. # Optional: mode-patt, use this spec for testpatt from runconfigs @@ -749,11 +749,11 @@ mode-patt TESTPATT # Optional: tag-expr, use this tag-expr to select tests tag-expr quick -# Optional: (not yet implemented), propagate these actions from the parent +# Optional: (not yet implemented, remove-runs is always propagated at this time), propagate these actions from the parent # test # Note// default is % for all propagate remove-runs archive ... --------------- 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: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -214,11 +214,12 @@ multiple sheets) -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified in the [archive-disks] section. cmd: keep-html, restore, save, save-remove - -generate-html : create a simple html tree for browsing your runs + -generate-html : create a simple html dashboard for browsing your runs + -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. -list-run-time : list time requered to complete runs. It supports following switches -run-patt -target-patt -dumpmode -list-test-time : list time requered to complete each test in a run. It following following arguments -runname -target -dumpmode @@ -374,11 +375,12 @@ "-list-servers" "-kill-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) "-one-pass" ;; "-local" ;; run some commands using local db access - "-generate-html" + "-generate-html" + "-generate-html-structure" "-list-run-time" "-list-test-time" ;; misc queries "-list-disks" "-list-targets" @@ -2255,11 +2257,17 @@ (let* ((toppath (launch:setup))) (if (tests:create-html-tree #f) (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) - +(if (args:get-arg "-generate-html-structure") + (let* ((toppath (launch:setup))) + ;(if (tests:create-html-tree #f) + (if (tests:create-html-summary #f) + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") + (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) + (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -1,11 +1,11 @@ -- CREATE TABLE IF NOT EXISTS keys ( -- id SERIAL PRIMARY KEY, -- fieldname TEXT, -- fieldtype TEXT, -- CONSTRAINT keyconstraint UNIQUE (fieldname)); - +DROP VIEW IF EXISTS area_tag_view; DROP TABLE IF EXISTS areas; DROP TABLE IF EXISTS ttype; DROP TABLE IF EXISTS runs; DROP TABLE IF EXISTS run_stats; DROP TABLE IF EXISTS test_meta; @@ -25,10 +25,14 @@ DROP TABLE IF EXISTS sessions; DROP TABLE IF EXISTS tags; DROP TABLE IF EXISTS users; DROP TABLE IF EXISTS webviews; DROP TABLE IF EXISTS area_tags; + +DROP TABLE IF EXISTS users_webviews; + + CREATE TABLE IF NOT EXISTS session_vars ( id SERIAL PRIMARY KEY, session_id INTEGER, page TEXT, @@ -56,10 +60,14 @@ id SERIAL PRIMARY KEY, tag_id INTEGER DEFAULT 0, area_id INTEGER DEFAULT 0, CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id)); +CREATE VIEW area_tag_view as +select a.id as aid, t.id as tid,area_name,tag_name from areas as a inner join area_tags as at on at.area_id = a.id +inner join tags as t on t.id = at.tag_id ; + INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.'); CREATE TABLE IF NOT EXISTS ttype ( id SERIAL PRIMARY KEY, target_spec TEXT DEFAULT ''); @@ -225,13 +233,14 @@ du INTEGER, archive_path TEXT); CREATE TABLE IF NOT EXISTS users( id SERIAL PRIMARY KEY , - usename TEXT NOT NULL, + username TEXT NOT NULL, fullname TEXT NOT NULL, email TEXT NOT NULL, + default_view TEXT default '', deleted INTEGER default 0 ); CREATE TABLE IF NOT EXISTS webviews( id SERIAL PRIMARY KEY , @@ -239,11 +248,23 @@ name TEXT NOT NULL, ttype_id INTEGER DEFAULT 0, view_specifics TEXT , col TEXT NOT NULL, row TEXT NOT NULL, + public INTEGER DEFAULT 0, deleted INTEGER default 0 ); + + + +CREATE TABLE IF NOT EXISTS users_webviews( + id SERIAL PRIMARY KEY , + user_id INTEGER NOT NULL, + webview_id INTEGER NOT NULL, + deleted INTEGER default 0, + searchpattern TEXT Default '' +); + -- TRUNCATE archive_blocks, archive_allocations, extradat, metadat, -- access_log, tests, test_steps, test_data, test_rundat, archives, runs, -- run_stats, test_meta, tasks_queue, archive_disks; 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))))) @@ -1226,11 +1222,14 @@ (let* ((rep (start-nn-server portnum)) (mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (script (configf:lookup mtconf "listener" "script"))) (print "Listening on port " portnum " for messages") - (let loop ((instr (nn-recv rep))) + (set-signal-handler! signal/int special-signal-handler) + (set-signal-handler! signal/term special-signal-handler) + + (let loop ((instr (nn-recv rep))) (print "received " instr ", running \"" script " " instr "\"") (system (conc script " '" instr "'")) (nn-send rep "ok") (loop (nn-recv rep)))) (print "ERROR: Port " portnum " already in use. Try another port"))))))) 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) @@ -2049,10 +2049,13 @@ (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f)))))) (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests (test-retry-time (make-hash-table)) + (backgrounded-remove-status (make-hash-table)) + (backgrounded-remove-last-visit (make-hash-table)) + (backgrounded-remove-result (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) (new-test-dat (rmt:get-test-info-by-id run-id test-id))) @@ -2064,68 +2067,130 @@ (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* ;; (rmt:sdb-qry 'getid (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree + (has-subrun (and (subrun:subrun-test-initialized? run-dir) + (not (subrun:subrun-removed? run-dir)))) (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat)) (uname (db:test-get-uname new-test-dat)) (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 + (has-subrun + ;; + (let ((last-visit (hash-table-ref/default backgrounded-remove-last-visit test-fulln 0)) + (now (current-seconds)) + (rem-status (hash-table-ref/default backgrounded-remove-status test-fulln 'not-started))) + (case rem-status + ((not-started) + (debug:print 0 *default-log-port* "WARNING: postponing removal of " test-fulln " with run-id " run-id " as it has a subrun") + (hash-table-set! backgrounded-remove-status test-fulln 'started) + (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) + (common:send-thunk-to-background-thread + (lambda () + (let* ((subrun-remove-succeeded + (subrun:remove-subrun run-dir keep-records))) + (hash-table-set! backgrounded-remove-result test-fulln subrun-remove-succeeded) + (hash-table-set! backgrounded-remove-status test-fulln 'done))) + name: (conc "remove-subrun:"test-fulln)) + + ;; send to back of line, loop + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))) + ) + ((started) + ;; if last visit was within last second, sleep 1 second + (if (< (- now last-visit) 1.0) + (thread-sleep! 1.0)) + (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) + ;; send to back of line, loop + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))) + ) + ((done) + ;; drop this one; if remaining, loop, else finish + (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) + (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception))) + (cond + ((eq? subrun-remove-succeeded 'exception) + (let* ((logfile (subrun:get-log-path run-dir "remove"))) + (debug:print 0 *default-log-port* "ERROR: removing subrun of of " test-fulln " with run-id " run-id " ; see logfile @ "logfile))) + (subrun-remove-succeeded + (debug:print 0 *default-log-port* "Now removing of " test-fulln " with run-id " run-id " since subrun was removed.") + ;;(runs:remove-test-directory new-test-dat mode) ;; let normal case handle this. it will go thru loop again as non-subrun + ) + (else + (let* ((logfile (subrun:get-log-path run-dir "remove"))) + (debug:print 0 *default-log-port* "WARNING: removal of subrun failed. Please check "logfile" for details.")))) + ;;(if (not (null? tal)) + ;; (loop (car tal)(cdr tal))) + + ;; send to back of line, loop (will not match has-subrun next time through) + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))) + )) + ) ; end case rem-status + ) ; end let + ); end cond has-subrun + + (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) + ;; BB TODO - manage has-subrun case (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)) (loop (car tal)(cdr tal)))) ((run-wait) + ;; BB TODO - manage has-subrun case (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests))))) ((archive) + ;; BB TODO - manage has-subrun case (if (and run-dir (not toplevel-with-children)) (let ((ddir (conc run-dir "/"))) (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html) (if (common:file-exists? ddir) ADDED subrun.scm Index: subrun.scm ================================================================== --- /dev/null +++ subrun.scm @@ -0,0 +1,210 @@ + +;; 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 + call-with-environment-variables) +(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") ;; provides db:test-get-id +;;(include "run_records.scm") +;;(include "test_records.scm") + +(define (subrun:subrun-test-initialized? test-run-dir) + (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) + (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) + #t + #f)) + +(define (subrun:subrun-removed? test-run-dir) + (if (subrun:subrun-test-initialized? test-run-dir) + (let ((flagfile (conc test-run-dir "/subrun.removed"))) + (if (common:file-exists? flagfile) + #t + #f)) + #t)) + +(define (subrun:set-subrun-removed test-run-dir) + (let ((flagfile (conc test-run-dir "/subrun.removed"))) + (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile))) + (with-output-to-file flagfile + (lambda () (print (current-seconds))))))) + +(define (subrun:testconfig-defines-subrun? testconfig) + (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested + +(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:remove-subrun test-run-dir keep-records ) +;; set state/status of test item +;; fork off megatest +;; set state/status of test item +;; + ;;(BB> "Entered subrun:remove-subrun with "test-fulln) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-remove-runs" + (if keep-records "-keep-records " "") + )) + (remove-result + (subrun:exec-sub-megatest test-run-dir action-switches-str "remove"))) + (if remove-result + (begin + (subrun:set-subrun-removed test-run-dir) + #t) + #f)) + #t)) + +(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)) + + +(define (subrun:selector+log-alist 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)))) + switch-alist)) + ;; note - get precmd from subrun section + ;; apply to submegatest commands + +(define (subrun:get-log-path test-run-dir log-prefix) + (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix)) + (res (alist-ref "-log" alist equal? #f))) + res)) + +(define (subrun:selector+log-switches test-run-dir log-prefix) + (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix)) + (res + (string-intersperse + (apply + append + (map + (lambda (x) + (list (car x) (cdr x))) + switch-alist)) + " "))) + res)) + +(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix) + (let* ((selector-switches (subrun:selector+log-switches test-run-dir log-prefix)) + (cmd (conc "megatest " selector-switches " " action-switches-str )) + (pid #f) + (proc (lambda () + (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd) + ;;(set! pid (process-run "/usr/bin/xterm" (list )))))) + (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) + (call-with-environment-variables + (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) + (lambda () + (common:without-vars proc "^MT_.*"))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (processloop (+ i 1))) + (begin + (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code) + (if (eq? 0 exit-code) + (begin + #t) + (begin + #f)))))))) + + + +;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -849,16 +849,26 @@ (begin (if pgdb-test-id (begin (if pgdb-data-id (begin - (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) + (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type)) (begin (print "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) - (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) - (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))) + (if (handle-exceptions + exn + (begin (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + + (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )) + ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) + (begin + ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) + (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))) + (exit)))) (hash-table-set! data-ht data-id pgdb-data-id )) (begin (print "Error: Test not in pgdb")))) (print "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -937,10 +937,177 @@ link))) (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t))) ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name)) html-body)) +(define (tests:create-html-summary outf) + (let* ((lockfile (conc outf ".lock")) + (linktree (common:get-linktree)) + (keys (rmt:get-keys)) + (area-name (common:get-testsuite-name))) + (if (common:simple-file-lock lockfile) + (begin + (let* ((runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (runs (vector-ref runsdat 1)) + (header (vector-ref runsdat 0)) + (oup (open-output-file (or outf (conc linktree "/targets.html")))) + (target-hash (test:create-target-hash runs header (length keys)))) + (test:create-target-html target-hash oup area-name linktree) + (test:create-run-html runs area-name linktree (length keys) header)) + (common:simple-file-release-lock lockfile)) + #f))) + +(define (test:get-test-hash test-data) + (let ((resh (make-hash-table))) + (map (lambda (test) + (let* ((test-name (vector-ref test 2)) + (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html")) + (conc (vector-ref test 10) "/test-summary.html" ) + (conc (vector-ref test 10) "/" (vector-ref test 13)))) + (test-item (vector-ref test 11)) + (test-status (vector-ref test 4))) + (if (not (hash-table-ref/default resh test-item #f)) + (hash-table-set! resh test-item (make-hash-table))) + (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path)))) + test-data) +resh)) + +(define (test:get-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + + +(define (test:create-run-html runs area-name linktree numkeys header) + (map (lambda (run) + (let* ((target (string-join (take (vector->list run) numkeys) "/")) + (run-name (db:get-value-by-header run header "runname")) + (oup (open-output-file (conc linktree "/" target "/" run-name "/run.html"))) + (run-id (db:get-value-by-header run header "id")) + (test-data (rmt:get-tests-for-run + run-id + "%" ;; testnamepatt + '() ;; states + '() ;; statuses + #f ;; offset + #f ;; num-to-get + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; 'shortlist ;; qrytype + 0 ;; last update + #f)) + (item-test-hash (test:get-test-hash test-data)) + (items (hash-table-keys item-test-hash)) + (test-names (test:get-data->b-keys item-test-hash items))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Runs View " run-name) + (s:body + (s:h1 "Runs View " ) + (s:h2 "Target" target) + (s:h2 "Run name" run-name) + (s:table 'border 1 + (s:tr + (s:td "Items") + (map (lambda (test) + (s:td test)) + test-names)) + (map (lambda (item) + (let* ((test-hash (hash-table-ref/default item-test-hash item #f))) + (if test-hash + (begin + (s:tr + (s:td item) + (map (lambda (test) + (let* ((test-details (hash-table-ref/default test-hash test #f)) + (status (if test-details + (car test-details))) + (link (if test-details + (cadr test-details)))) + (if test-details + (s:td 'class status + (s:a 'href link status )) + (s:td "")))) + test-names)))))) + (sort items string<=?)))))) + (close-output-port oup))) +runs)) + +(define (test:create-target-hash runs header numkeys) + (let ((resh (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (db:get-value-by-header run header "runname")) + (target (string-join (take (vector->list run) numkeys) "/")) + (run-list (hash-table-ref/default resh target #f))) + + (if (not run-list) + (hash-table-set! resh target (list run-name)) + (hash-table-set! resh target (cons run-name run-list))))) + runs) + resh)) + +(define (test:get-max-run-cnt target-hash targets) + (let* ((cnt 0 )) + (map (lambda (target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (run-length (if runs + (length runs) + 0))) + + (if (< cnt run-length) + (set! cnt run-length)))) + targets) +cnt)) + +(define (test:pad-runs target-hash targets max-row-length) + (map (lambda (target) + (let loop ((run-list (hash-table-ref/default target-hash target #f))) + (if (< (length run-list) max-row-length) + (begin + (hash-table-set! target-hash target (cons "" run-list)) + (loop (hash-table-ref/default target-hash target #f) ))))) + targets) + target-hash) + +(define (test:create-target-html target-hash oup area-name linktree) + (let* ((targets (hash-table-keys target-hash)) + (max-row-length (test:get-max-run-cnt target-hash targets)) + (pad-runs-hash (test:pad-runs target-hash targets max-row-length))) + (s:output-new + oup + (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f) + + (s:title "Target View " area-name) + (s:body + (s:h1 "Target View " area-name) + (s:table 'id "LinkedList1" 'border "1" + (s:tr 'class "something" + (s:td "Target") + (s:td 'colspan max-row-length "Runs")) + (let* ((tbl (map (lambda (target) + (s:tr + (s:td target) + (let* ((runs (hash-table-ref/default target-hash target #f)) + (rest-row (map (lambda (run) + (if (equal? run "") + (s:td run) + (s:td + (s:a 'href (conc linktree "/" target "/" run "/run.html") run)))) + (reverse runs)))) + rest-row))) + targets))) + tbl))))) + (close-output-port oup))) (define (tests:create-html-tree-old outf) (let* ((lockfile (conc outf ".lock")) (runs-to-process '()))