Megatest

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
;; (use zmq)

(import (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb)
(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit client))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

;; client:setup
(define (client:setup #!key (numtries 50))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
  (change-directory *toppath*) ;; This is probably NOT needed 
  (push-directory *toppath*) ;; This is probably NOT needed 
  (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
  (let* ((hostinfo  (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out
			(open-run-close tasks:get-best-server tasks:open-db)
			#f)))
    ;; if have hostinfo then extract the transport type 
    ;; else fall back to fs
    (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)

      ((zmq)
       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))
      (else  ;; default to fs
       (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs")
       (set! *transport-type* 'fs)
       (set! *megatest-db*    (open-db))))))
       (set! *megatest-db*    (open-db))))
    (pop-directory)))

;; client:signal-handler
(define (client:signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
   (let ((th1 (make-thread (lambda ()

	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (mt:get-run-stats))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 (apply max (map cadr col-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
				(max-col-vis  (if (> max-col 10) 10 max-col))
				(numrows      1)
				(numcols      1))
			   (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
			   (iup:attribute-set! stats-matrix "NUMCOL" max-col )
			   (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col)
			   (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
			   (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))

			   ;; Row labels
			   (for-each (lambda (ind)
				       (let* ((name (car ind))
					      (num  (cadr ind))
					      (key  (conc num ":0")))

	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  (change-directory testpath)
	  ;; (set! *runremote* runremote)
	  (set! *transport-type* (string->symbol transport))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (debug:print-info 1 "Runing -runstep, first change to directory " work-area)
	  (change-directory work-area)
	  ;; can setup as client for server mode now
	  ;; (client:setup)

	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      ;; DO NOT put this one into either cdb:remote-run or open-run-close
	      (db:load-test-data db test-id work-area: work-area))

			 (fullcmd    (conc "(" (string-intersperse 
						(cons cmd params) " ")
					   ") " redir " " logfile)))
		    ;; mark the start of the test
		    ;; DO NOT run remote
		    (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area)
		    ;; run the test step
		    (debug:print-info 2 "Running \"" fullcmd "\"")
		    (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd)) ;; cmd params))
		    (set! *globalexitstatus* exitstat)
		    (change-directory testpath)
		    ;; (change-directory testpath)
		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
		    (if logprofile
			(let* ((htmllogfile (conc stepname ".html"))
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (debug:print-info 2 "running \"" cmd "\"")
			  (change-directory startingdir)

#!/bin/bash

# megatest -step wasting_time :state start :status n/a -m "This is a test step comment"
# sleep 20
# megatest -step wasting_time :state end :status $?

$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all done eh?" -m "This is a test step comment"
$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo alldone" -m "This is a test step comment"

$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_err "This is the first error"