Megatest

mtest-reaper: $(PREFIX)/bin/mtest-reaper

# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

# Work around missing libraries on crappy corporate compute farm (hearafter known as CCCF)
ifeq ($(ARCHSTR),12.5)
EXTRALIBS_HACK=$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
else
EXTRALIBS_HACK=
endif

$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
	$(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so

$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 : lib/libpangox-1.0.so.0
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
	$(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0

$(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
	$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0

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 \
	  $(EXTRALIBS_HACK)

# $(PREFIX)/bin/newdashboard

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

(define config-lookup configf:lookup)
(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 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)
     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
     (else default))))

	    )))))

;; 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)))
	 (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)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))

				(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (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 "FGCOLOR")))
				       (iup:attribute-set! btn "FGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"

				(map cadr *common:std-statuses*)))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (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 "FGCOLOR")))
				       (iup:attribute-set! btn "FGCOLOR" newcolor))))
			       btns)))
	       btns))))))

(define (dashboard-tests:run-a-step info)
  #t)

;; (define (dashboard-tests:step-run-control testdat stepname testconfig)

  license GPL, Copyright (C) Matt Welland 2012-2017

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
"))

;;   -server host:port     : connect to host:port instead of db access

			"-run"
			"-test"
                        "-xterm"
			"-debug"
			"-host" 
			"-transport"
                        "-start-dir"
			"-target"   ;; use as filter
			"-runname"  ;; use as filter
			"-testpatt" ;; use as filter
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"

					  (else
					   teststate)))
			   (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 "FGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE" (conc "<span weight=\"bold\">"  buttontxt "</span>")))
		      (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)))
		(set! rown (+ rown 1))))
	    (dboard:tabdat-all-test-names tabdat)))

 ;;(iup:frame
 ;; #: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 ()

				(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))
		  #:expand "HORIZONTAL"
		  ;; #:size "10x30"
		  ))
	 (tb
          (iup:treebox
           #:value 0
           #:title "Runs"     ;;  was #:name -- iup 3.19 changed

                        (dboard:tabdat-curr-run-id-set! tabdat run-id)
                        (dboard:tabdat-view-changed-set! tabdat #t))
                      (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
      ))))

;; browse runs as a tree. Used in both "Runs" tab and

	   ;; 					   (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
	   ;; 					   (mark-for-update tabdat))))
	   (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 "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 "FGCOLOR" sel-color)
					     (iup:attribute-set! hide "FGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (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))) 
	)

        ;; insert extra widget here

	 (i               0)
	 (btn-height      (dboard:tabdat-runs-btn-height runs-dat))
	 (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 
			(map (lambda (x)		
			       (let ((res (iup:hbox
					   #:expand "HORIZONTAL"
					   (iup:label x
						      #:size (conc 40 btn-height)
						      #:fontsize btn-fontsz
						      #:expand "NO") ;; "HORIZONTAL")
					   (iup:textbox
					    #:size (conc 35 btn-height)
					    #:fontsize btn-fontsz
					    #: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
						       (dboard:tabdat-target-set! runs-dat #f)
						       ;; ensure fields text boxes are used

	(loop (+ runnum 1) 0 (make-vector ntests) '()))
       (else
	(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)
				   (if (eq? pressed 1)
				       (let* ((toolpath (car (argv)))

			   #:action (lambda (obj val txt)
				      (debug:catch-and-dump
				       (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 (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 ()
					 (if (not (equal? val ""))
					     (begin

  (let* ((tmp-area            (common:get-db-tmp-area))
	 (server-start        (conc tmp-area "/.server-start"))
	 (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) ;; 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/" new-fname))
				       )
                                  (debug:print 0 *default-log-port* msg)
                                  (if (common:file-exists? full-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
	     (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*))))
      (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)
		     (T      . server)
		     (pid    . ,(current-process-id)))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

;; (declare (unit megatest-version))

(define megatest-version 1.6579)

Queries:
   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
			     
Selectors 		     
  -immediate                 : apply this action immediately, default is to queue up actions

			    (handle-exceptions
				exn
				(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 (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))
	 (actual-action  (if action
			     (if (equal? action "sync-prepend")

	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (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 go)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (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))
	   ;; [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))
		  (sect-dat (configf:get-section mtconf (car remargs))))
	     (if sect-dat

                                   )

                                  )

                                )))
                           (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)
                       
                         (let loop ((instr (nn-recv rep)))
                             (nn-send rep "ok")
                             (let ((ctime (date->string (current-date)))) 
                             (if  (equal? instr "time-to-die")
                              (begin 
                              (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
                               (let ((pid  (current-process-id)))

           (runname (common:args-get-runname))
           (rundir (db:test-get-rundir testdat))
           (tarfiledir (conc *toppath* "/reruns"))
           (status (db:test-get-status testdat))
           (comment (conc "\"" (db:test-get-comment testdat) "\"" ))
           (testname (db:test-get-testname testdat))
           (itempath (db:test-get-item-path testdat))
           (file-body (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc  "." (string-translate itempath "/" "-")) "")))
           (log-file (conc file-body ".log"))
           ;; (log-file        (conc status "-" (string-translate target "/" "-") "-" runname "." testname (if (not (string=? itempath "")) (conc  "." (string-translate itempath "/" "-")) "") ".log"))
           (full-log-fname  (conc log-dir "/" log-file))
           (tarfilename (conc file-body ".tar"))
           ;; (tarfilename (conc status "." (string-translate target "/" "-") "." runname "." testname (if (not (string=? itempath "")) (conc  "." (string-translate itempath "/" "-")) "") ".tar"))
           )
      (if rerun-hook
	  (let* ((use-log-dir (if (not (directory-exists? log-dir))
				  (handle-exceptions
				      exn
				      (begin
					(debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir ", exn=" exn)
					#f)
				    (create-directory log-dir #t)
				    #t)
				  #t))
		 (start-time   (current-seconds))
		 (actual-logf  (if use-log-dir full-log-fname log-file))
                 (sys-call-text (conc rerun-hook " " tarfilename " " rundir " " actual-logf " " runname " " tarfiledir " " status " " target " " comment " " testname " " itempath " >> " actual-logf " 2>&1"))
                 )
	    (debug:print 2 *default-log-port* "Found rerun-hook in config:" rerun-hook)
	    (handle-exceptions
		exn
		(begin
		  (print-call-chain *default-log-port*)
		  (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
		  (debug:print 0 *default-log-port* "ERROR: failed to run rerun-hook " rerun-hook ", check the log " log-file))
	      (debug:print-info 0 *default-log-port* "running rerun-hook: \"" rerun-hook "\", log is " actual-logf)

    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launched flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
				 (if x (string->number x) #f)))
	   (config-rerun-cnt (if config-reruns
				 config-reruns
				 1)))

	    
	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (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,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")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here

(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: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))
	     (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 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)
            #t
            #f))

         ;; 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))))
    (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)
  (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix))
         (res   (alist-ref "-log" alist equal? #f)))

#     You should have received a copy of the GNU General Public License
#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

prefix=$1
cmd=$2
target=$3
cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
libdir="$prefix/bin/.$(lsb_release -sr)/lib"

# we wish to create a var in cfg.sh for finding sqlite3 executable
chicken_bin_dir=$(dirname $(which csi))
if [[ -e $chicken_bin_dir/sqlite3 ]];then
    sqlite3_exe=$chicken_bin_dir/sqlite3
else
    sqlite3_exe=$(which sqlite3)
fi

if [ "$LD_LIBRARY_PATH" != "" ];then
  echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2
  echo "INFO: Writing $cfgfile" >&2
( cat << __EOF
if [ -z \$MT_ORIG_ENV ]; then
    export MT_ORIG_ENV=\$( $prefix/bin/serialize-env )
fi

if [ "\$LD_LIBRARY_PATH" != "" ];then
  export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH:$libdir
else
  export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$libdir
fi

export MT_SQLITE3_EXE=$sqlite3_exe
__EOF
) > $cfgfile
  echo 
else