Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -333,23 +333,23 @@ $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0 if [[ $(ARCHSTR) == 12.5 ]]; then \ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ $(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \ fi + install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \ - $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \ + $(EXTRALIBS_HACK) $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \ $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 -# $(PREFIX)/bin/.$(ARCHSTR)/ndboard # $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -531,12 +531,12 @@ (define configf:read-file read-config) ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) ;; -(define (configf:lookup-number cfdat section varname #!key (default #f)) - (let* ((val (configf:lookup *configdat* section varname)) +(define (configf:lookup-number cfgdat section varname #!key (default #f)) + (let* ((val (configf:lookup cfgdat section varname)) (res (if val (string->number (string-substitute "\\s+" "" val #t)) #f))) (cond (res res) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -261,19 +261,34 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((test-run-dir (db:test-get-rundir testdat)) (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea silent: #t)))) - (if subarea - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:button - "Launch Dashboard" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir)))) - (iup:vbox)))) + (area-exists (and subarea (common:file-exists? subarea silent: #t))) + (target #f) + (runname #f) + (cmd-parts-file (conc test-run-dir "/subrun-command-parts.sexp"))) + (if (file-exists? cmd-parts-file) ;; existance of this file is sufficient to *try* opening a dashboard + (let* ((cmd-parts (if (file-exists? cmd-parts-file) + (with-input-from-file cmd-parts-file + read) + '())) + (target (alist-ref "-target" cmd-parts equal?)) + (runname (alist-ref "-runname" cmd-parts equal?)) + (run-area (alist-ref "-startdir" cmd-parts equal?))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:vbox + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir))) + (iup:button + "Launch Dashboard+Filter" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir target: target runname: runname)))))) + (iup:vbox )))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) @@ -324,12 +339,12 @@ (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) + (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR"))) + (iup:attribute-set! btn "FGCOLOR" newcolor)))) btns))) btns)) (apply iup:hbox (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) @@ -358,12 +373,12 @@ (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name status) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) + (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR"))) + (iup:attribute-set! btn "FGCOLOR" newcolor)))) btns))) btns)))))) (define (dashboard-tests:run-a-step info) #t) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -64,10 +64,13 @@ Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check -use-db-cache : access database via cache + -target T : prefill target filter with given target pattern + -runname R : prefill runname filter with given runname pattern + -testpatt P : prefill testpatt filter with given testpatt Misc -rows R : set number of rows -cols C : set number of columns ")) @@ -86,10 +89,13 @@ "-xterm" "-debug" "-host" "-transport" "-start-dir" + "-target" ;; use as filter + "-runname" ;; use as filter + "-testpatt" ;; use as filter ) (list "-h" "-use-server" "-guimonitor" "-main" @@ -1171,13 +1177,14 @@ (button (vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) + #;(iup:attribute-set! button "BGCOLOR" color) + (iup:attribute-set! button "FGCOLOR" color)) (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) + (iup:attribute-set! button "TITLE" (conc "" buttontxt ""))) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) @@ -1520,29 +1527,27 @@ ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) + +(define (dboard:runs-tree-txtbox-change tabdat val a b) + (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) + (dashboard:update-run-command tabdat)) ;; browse runs as a tree. Used in both "Runs" tab and ;; in the runs control panel. ;; (define (dboard:runs-tree-browser commondat tabdat) (let* ((txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () - ;; for the Runs view we put the list - ;; of keyvals into tabdat target for - ;; the Run Controls we put then update - ;; the run-command - (if b (dboard:tabdat-target-set! tabdat - (string-split b "/"))) - (dashboard:update-run-command tabdat)) + (dboard:runs-tree-txtbox-change tabdat val a b)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines - (dboard:tabdat-test-patts-use tabdat)) + (dboard:tabdat-test-patts-use tabdat)) #:expand "HORIZONTAL" ;; #:size "10x30" )) (tb (iup:treebox @@ -1583,10 +1588,18 @@ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:tabdat-runs-tree-set! tabdat tb) + (if (args:get-arg "-runname") + (let ((runname (args:get-arg "-runname"))) + (update-search commondat tabdat "runname" runname) + #;(hash-table-set! (dboard:tabdat-searchpatts tabdat) "runname" runname))) + (if (args:get-arg "-target") ;; + (let ((target (args:get-arg "-target"))) + (iup:attribute-set! txtbox value: target) + (dboard:runs-tree-txtbox-change tabdat #f #f target))) (iup:detachbox (iup:vbox txtbox tb )))) @@ -2485,22 +2498,22 @@ (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) + (iup:attribute-set! hide "FGCOLOR" sel-color) + (iup:attribute-set! show "FGCOLOR" nonsel-color) (mark-for-update tabdat)))) (set! show (iup:button "Show" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - (iup:attribute-set! show "BGCOLOR" sel-color) - (iup:attribute-set! hide "BGCOLOR" nonsel-color) + (iup:attribute-set! show "FGCOLOR" sel-color) + (iup:attribute-set! hide "FGCOLOR" nonsel-color) (mark-for-update tabdat)))) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) + (iup:attribute-set! hide "FGCOLOR" sel-color) + (iup:attribute-set! show "FGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... (iup:vbox (iup:hbox hide show) sort-lb))) ) @@ -2761,10 +2774,15 @@ (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) + (if (args:get-arg "-runname") + (let ((runname (args:get-arg "-runname"))) + (update-search commondat runs-dat "runname" runname) + #;(hash-table-set! (dboard:tabdat-searchpatts tabdat) "runname" runname))) + ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -2776,11 +2794,12 @@ #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz - #:value "%" + #:value (if (and (args:get-arg "-runname")(equal? x "runname")) + (args:get-arg "-runname") "%") #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) ;; each field ;; (field name is "x" var) live updates ;; the search filter as it is typed @@ -2869,10 +2888,11 @@ (let* ((button-key (mkstr runnum testnum)) (butn (iup:button "" ;; button-key #:size (conc cell-width btn-height ) #:expand "HORIZONTAL" + #:MARKUP "YES" #:fontsize btn-fontsz #:button-cb (lambda (obj a pressed x y btn . rem) ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -1161,11 +1161,11 @@ (lambda () ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command tabdat)) "command-runname-selector tb action")) - #:value (or default-run-name (dboard:tabdat-run-name tabdat)))) + #:value (or (args:get-arg "-runname") default-run-name (dboard:tabdat-run-name tabdat)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) (debug:catch-and-dump (lambda () Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -576,26 +576,31 @@ (server-started (conc tmp-area "/.server-started")) (start-time (common:lazy-modification-time server-start)) (started-time (common:lazy-modification-time server-started)) (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting (start-time-old (> (- (current-seconds) start-time) 5)) - (cleanup-proc (lambda (msg) + (cleanup-proc (lambda (msg) ;; would like to use (modulo (current-seconds) 60) instead of process-id to wrap filenames (let* ((serv-fname (conc "server-" (current-process-id) "-" (get-host-name) ".log")) + (new-fname (conc "server-" (modulo (current-seconds) 60) "-" (get-host-name) ".log")) (full-serv-fname (conc *toppath* "/logs/" serv-fname)) - (new-serv-fname (conc *toppath* "/logs/" "defunct-" serv-fname))) + ;; (new-serv-fname (conc *toppath* "/logs/" "defunct-" serv-fname)) + (new-serv-fname (conc *toppath* "/logs/" new-fname)) + ) (debug:print 0 *default-log-port* msg) (if (common:file-exists? full-serv-fname) - (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname)) + (with-output-to-pipe "at now + 10 minutes" (lambda () + (print "mv -f " full-serv-fname " " new-serv-fname))) + ;; (system (conc "sleep 10;mv -f " full-serv-fname " " new-serv-fname)) (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname)) (exit))))) - #;(if (and (not start-time-old) ;; last server start try was less than five seconds ago + (if (and (not start-time-old) ;; last server start try was less than five seconds ago (not server-starting)) (begin (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting") (exit))) ;; lets not even bother to start if there are already three or more server files ready to go - #;(let* ((num-alive (server:get-num-alive (server:get-list *toppath*)))) + (let* ((num-alive (server:get-num-alive (server:get-list *toppath*)))) (if (> num-alive 3) (begin (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up")) (exit)))) (common:save-pkt `((action . start) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -154,10 +154,11 @@ show [areas|contours... ] : show areas, contours or other section from megatest.config gendot : generate a graphviz dot file from pkts. Contour actions: process : runs import, rungen and dispatch + go : runs import, rungen and dispatch every five minutes forever Trigger propagation actions: tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section tlisten -port N : listen for trigger info on port N @@ -773,11 +774,11 @@ (begin (print-call-chain) (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area) (print " message: " ((condition-property-accessor 'exn 'message) exn)) runname) - (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")") + (print "(mapper " (string-intersperse (map conc (list runkey runname area area-path reason contour mode-patt)) ", ") ")") (mapper runkey runname area area-path reason contour mode-patt)) (case callname ((auto #f) runname) (else runtrans))))) (new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour)) @@ -1612,23 +1613,70 @@ ;; (hash-table-keys adjargs)) (let-values (((uuid pkt) (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss))) (print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log")) (write-pkt pktsdir uuid pkt)))) - ((dispatch import rungen process) + ((dispatch import rungen process go) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) - (toppath (configf:lookup mtconf "scratchdat" "toppath"))) + (toppath (configf:lookup mtconf "scratchdat" "toppath")) + (period (configf:lookup-number mtconf "mtutil" "autorun-period" default: 300)) + (rest-time (configf:lookup-number mtconf "mtutil" "autorun-rest" default: 30))) + (print "Using period="period" and rest time="rest-time) (case (string->symbol *action*) ((process) (begin (common:load-pkts-to-db mtconf) (generate-run-pkts mtconf toppath) (common:load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) ((import) (common:load-pkts-to-db mtconf)) ;; import pkts ((rungen) (generate-run-pkts mtconf toppath)) - ((dispatch) (dispatch-commands mtconf toppath))))) + ((dispatch) (dispatch-commands mtconf toppath)) + ;; [mtutil] + ;; # approximate interval between run processing in mtutil (seconds) + ;; autorun-period 300 + ;; # minimal rest period between processing + ;; autorun-rest 30 + ((go) + ;; determine if I'm the boss + (if (file-exists? "mtutil-go.pid") + (begin + (print "ERROR: mtutil go is already running under host and pid " (with-input-from-file "mtutil-go.pid" read-line) + ". Please kill that process and remove the file \"mutil-go.pid\" and try again.") + (exit))) + (with-output-to-file "mtutil-go.pid" (lambda ()(print (get-host-name) " " (current-process-id)))) + (print "Starting long running import, rungen, and process loop") + (if (file-exists? "do-not-run-mtutil-go") + (begin + (print "NOTE: Removing flag file "(current-directory)"/do-not-run-mtutil-go") + (delete-file* "do-not-run-mtutil-go"))) + (let loop ((last-run (- (current-seconds) (+ period 10))) ;; fake out first time in + (this-run (current-seconds))) + (if (file-exists? "do-not-run-mtutil-go") + (begin + (print "File do-not-run-mtutil-go exists, exiting.") + (delete-file* "mtutil-go.pid") + (exit))) + (let ((delta (- this-run last-run))) + (if (>= delta period) + (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat))) + (print "Running import at " (current-seconds)) + (common:load-pkts-to-db mtconf) + (print "Running generate run pkts at " (current-seconds)) + (generate-run-pkts mtconf toppath) + (print "Running run dispatch at " (current-seconds)) + (common:load-pkts-to-db mtconf) + (dispatch-commands mtconf toppath) + (print "Done running import, generate, and dispatch done in " (- (current-seconds) this-run)) + (print "NOTE: touch " (current-directory) "/do-not-run-mtutil-go to kill this runner.") + (loop this-run (current-seconds))) + (let ((now (current-seconds))) + (print "Sleeping " rest-time " seconds, next run in aproximately " (- period (- now last-run)) " seconds") + (thread-sleep! rest-time) + (loop last-run (current-seconds)))))) + (delete-file* "mtutil-go.pid"))))) ;; misc ((show) (if (> (length remargs) 0) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) @@ -1807,46 +1855,52 @@ ) ))) (loop (nn-recv rep)))) (print "ERROR: Port " portnum " already in use. Try another port"))))))) - - - - - ((tlisten) - (if (null? remargs) - (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"") - (let ((portnum (string->number (car remargs)))) - - (if (not portnum) - (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs)) - (begin - (if (not (is-port-in-use portnum)) - (let* ((rep (start-nn-server portnum)) - (mtconfdat (simple-setup (args:get-arg "-start-dir"))) - (mtconf (car mtconfdat)) - (contact (configf:lookup mtconf "listener" "owner")) - (script (configf:lookup mtconf "listener" "script"))) - (print "Listening on port " portnum " for messages.") - (set-signal-handler! signal/int (lambda (signum) - (set! *time-to-exit* #t) - (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") - (let ((email-body (mtut:stml->string (s:body - (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) - (sendmail contact "Listner has been terminated." email-body use_html: #t)) - (exit))) - (set-signal-handler! signal/term (lambda (signum) - (set! *time-to-exit* #t) - (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") - (let ((email-body (mtut:stml->string (s:body - (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) - (sendmail contact "Listner has been terminated." email-body use_html: #t)) - (exit))) - - ;(set-signal-handler! signal/term special-signal-handler) - + + ((tlisten) + (if (null? remargs) + (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"") + (let ((portnum (string->number (car remargs)))) + + (if (not portnum) + (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs)) + (begin + (if (not (is-port-in-use portnum)) + (let* ((rep (start-nn-server portnum)) + (mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (contact (configf:lookup mtconf "listener" "owner")) + (script (configf:lookup mtconf "listener" "script"))) + (print "Listening on port " portnum " for messages.") + (set-signal-handler! signal/int + (lambda (signum) + (set! *time-to-exit* #t) + (debug:print-error 0 *default-log-port* "Received signal " signum + " sending email befor exiting !!") + (let ((email-body (mtut:stml->string + (s:body + (s:p (conc "Received signal " signum + ". Lister has been terminated on host " + (get-environment-variable "HOST") ". ")))))) + (sendmail contact "Listner has been terminated." email-body use_html: #t)) + (exit))) + (set-signal-handler! signal/term (lambda (signum) + (set! *time-to-exit* #t) + (debug:print-error 0 *default-log-port* "Received signal " + signum " sending email befor exiting !!") + (let ((email-body (mtut:stml->string + (s:body + (s:p (conc "Received signal " signum + ". Lister has been terminated on host " + (get-environment-variable "HOST") ". ")))))) + (sendmail contact "Listner has been terminated." email-body use_html: #t)) + (exit))) + + ;; (set-signal-handler! signal/term special-signal-handler) + (let loop ((instr (nn-recv rep))) (nn-send rep "ok") (let ((ctime (date->string (current-date)))) (if (equal? instr "time-to-die") (begin Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -823,11 +823,11 @@ (if (> run-count 0) ;; handle reruns (begin (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) - (hash-table-set! flags "-rerun" "ABORT,DEAD,STUCK/DEAD,n/a,ZERO_ITEMS")) + (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS")) ;; recursive call to self (debug:print-info 0 *default-log-port* "Re-running tests with status " (hash-table-ref/default flags "-rerun" "")) (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))) (launch:end-of-run-check run-id))) (debug:print-info 0 *default-log-port* "No tests to run"))) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -43,15 +43,17 @@ (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) #t #f)) -(define (subrun:launch-dashboard test-run-dir) +(define (subrun:launch-dashboard test-run-dir #!key (target #f)(runname #f)) (if (subrun:subrun-test-initialized? test-run-dir) - (let* ((subarea (subrun:get-runarea test-run-dir))) + (let* ((subarea (subrun:get-runarea test-run-dir)) + (params (conc (if target (conc " -target " target) "") + (if runname (conc " -runname " runname) "")))) (if (and subarea (common:file-exists? subarea)) - (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) + (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER nbfake dashboard " params)))))) (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) @@ -209,11 +211,14 @@ (cons "-log" logfile) (map (lambda (item) (if (equal? (car item) "-testpatt") (cons "-testpatt" testpatt) item)) - switch-alist-pre)))) + switch-alist-pre)))) + (with-output-to-file "subrun-command-parts.sexp" + (lambda () + (pp switch-alist))) switch-alist)) ;; note - get precmd from subrun section ;; apply to submegatest commands (define (subrun:get-log-path test-run-dir log-prefix)