Megatest

(include "env.scm")
(include "diff-report.scm")
(include "ods.scm")

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

     ;;======================================================================
     ;; Test commands (i.e. for use inside tests)
     ;;======================================================================
     
     (define (megatest:step step state status logfile msg)
       (if (not (getenv "MT_CMDINFO"))
           (begin
     	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
     	(exit 5))
           (let* ((cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
     	     (transport (assoc/default 'transport cmdinfo))
     	     (testpath  (assoc/default 'testpath  cmdinfo))
     	     (test-name (assoc/default 'test-name cmdinfo))
     	     (runscript (assoc/default 'runscript cmdinfo))
     	     (db-host   (assoc/default 'db-host   cmdinfo))
     	     (run-id    (assoc/default 'run-id    cmdinfo))
     	     (test-id   (assoc/default 'test-id   cmdinfo))

     	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
     	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
     	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
     	    (begin
     	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
     	      (exit 6))))))

     ;;======================================================================
     ;; full run
     ;;======================================================================
     
     (define (handle-run-requests target runname keys keyvals need-clean)	 
       (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
           ;; For rerun-clean do we or do we not support the testpatt?
           (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
     			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
     	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
     			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
     	(hash-table-set! args:arg-hash "-preclean" #t)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))

     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
     			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
     			 ;; state:  states
     			 status: statuses
     			 new-state-status: "NOT_STARTED,n/a")))
       ;; RERUN ALL
       (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
           (let* ((rconfig (full-runconfigs-read)))
     	(hash-table-set! args:arg-hash "-preclean" #t)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
     			 state:  #f
     			 ;; status: statuses
     			 new-state-status: "NOT_STARTED,n/a")
     	(runs:clean-cache target runname *toppath*)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
     			 ;; state:  states
     			 status: #f
     			 new-state-status: "NOT_STARTED,n/a")))
       (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
     			       (if x (string->number x) #f)))
     	 (rerun-cnt (if config-reruns
     			config-reruns
     			1)))
     
         (runs:run-tests target
     		    runname
     		    #f ;; (common:args-get-testpatt #f)
     		    ;; (or (args:get-arg "-testpatt")
     		    ;;     "%")
     		    (bdat-user *bdat*)
     		    args:arg-hash
     		    run-count: rerun-cnt)))

     ;; csv processing record
     (define (make-refdb:csv)
       (vector 
        (make-sparse-array)
        (make-hash-table)
        (make-hash-table)
        0
        0))
     (define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
     (define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
     (define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
     (define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
     (define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
     (define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
     (define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
     (define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
     (define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
     (define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))
     
     (define (get-dat results sheetname)
       (or (hash-table-ref/default results sheetname #f)
           (let ((tmp-vec  (make-refdb:csv)))
     	(hash-table-set! results sheetname tmp-vec)
     	tmp-vec)))
     
     ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
     (define (open-logfile logpath-in)
       (condition-case
        (let* ((log-dir (or (pathname-directory logpath-in) "."))
     	  (fname   (pathname-strip-directory logpath-in))
     	  (logpath (if (> (string-length fname) 250)
     		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
     			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
     			 newlogf)
     		       logpath-in)))
          (if (not (directory-exists? log-dir))
              (system (conc "mkdir -p " log-dir)))
          (open-output-file logpath))
        (exn ()
             (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
             (define *didsomething* #t)  
             (exit 1))))

(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (getenv "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity *verbosity* debugstr)

     	#f)
      #t))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out
     
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help