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




;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file




























;;



(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))











  (if (common:file-exists? debugcontrolf)












      (load debugcontrolf)))




























































;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;



(if (and *usage-log-file*


	 (file-writable? *usage-log-file*))
    (with-output-to-file


	*usage-log-file*
      (lambda ()

	(print

	 (if *usage-use-seconds*
	     (current-seconds)
	     (time->string
	      (seconds->local-time (current-seconds))

	      "%Yww%V.%w %H:%M:%S"))





	 " "
	 (current-user-name) " "
	 (current-directory) " "


	 "\"" (string-intersperse (argv) " ") "\""))

      #:append))









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

     
     # Get test path, use '.' to get a single path or a specific path/file pattern
     megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
     
     Called as " (string-intersperse (argv) " ") "
     Version " megatest-version ", built from " megatest-fossil-hash ))
     




























     ;;  -gui                    : start a gui interface
     ;;  -config fname           : override the runconfigs file with fname
     
     ;; process args
     (define remargs (args:get-args 
     		 (argv)
     		 (list  "-runtests"  ;; run a specific test

     ;;
     (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
       (if targ (setenv "MT_TARGET" targ)))
     
     ;; The watchdog is to keep an eye on things like db sync etc.
     ;;
     
(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)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (and (not (args:get-arg "-debug-noprop"))
      	     (or (args:get-arg "-debug")
      		 (not (getenv "MT_DEBUG_MODE"))))
      	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
      				    (string-intersperse (map conc *verbosity*) ",")
      				    (conc *verbosity*))))))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
     	       (list?   verbosity)))
      (begin
     	(print "ERROR: Invalid debug value \"" vstr "\"")
     	#f)
      #t))
  
;;      (define (debug:debug-mode n)
;;        (cond
;;         ((and (number? *verbosity*)   ;; number number
;;      	 (number? n))
;;          (<= n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   number
;;      	 (number? n))
;;          (member n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   list
;;      	 (list? n))
;;          (not (null? (lset-intersection! eq? *verbosity* n))))
;;         ((and (number? *verbosity*)
;;      	 (list? n))
;;          (member *verbosity* n))))

     
     ;; 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))))
     
     ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
     ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
     ;; where (launch:setup) returns #f?
     ;;
     (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
         (handle-exceptions
     	exn

     	       (string-intersperse 
     		x
     		" => "))
     	     (common:get-disks *configdat*))
     	"\n"))
           (set! *didsomething* #t)))
     
     ;; 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)))
     
     (if (args:get-arg "-refdb2dat")
         (let* ((input-db (args:get-arg "-refdb2dat"))
     	   (out-file (args:get-arg "-o"))
     	   (out-fmt  (or (args:get-arg "-dumpmode") "scheme"))
     	   (out-port (if (and out-file 
     			      (not (member out-fmt '("sqlite3" "csv"))))
     			 (open-output-file out-file)
     			 (current-output-port)))

     					     (conc "/" (db:test-get-item-path testdat)))
     					 )))
     	      (print testfullname " " (db:test-get-comment testdat))))
     	    tests)))
            runs)
           (set! *didsomething* #t)))
           
     ;;======================================================================
     ;; 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"))
     			 ;; "%" ;; (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")
     	(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 #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)))
     
     ;; get lock in db for full run for this directory
     ;; for all tests with deps
     ;;   walk tree of tests to find head tasks
     ;;   add head tasks to task queue
     ;;   add dependant tasks to task queue 
     ;;   add remaining tasks to task queue

     		(begin
     		  (launch:recover-test run-id test-id)
     		  (set! *didsomething* #t))
     		(begin
     		  (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
     		  (exit 1)))))))
     
     ;;======================================================================
     ;; 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))
     	     (itemdat   (assoc/default 'itemdat   cmdinfo))
     	     (work-area (assoc/default 'work-area cmdinfo))
     	     (db        #f))
     	(change-directory testpath)
     	(if (not (launch:setup))
     	    (begin
     	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
     	      (exit 1)))
     	(if (and state status)
     	    (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))))))
     
     (define (main)
     (if (args:get-arg "-step")
         (begin
           (thread-sleep! 1.5)
           (megatest:step 
            (args:get-arg "-step")
            (or (args:get-arg "-state")(args:get-arg ":state"))
            (or (args:get-arg "-status")(args:get-arg ":status"))
            (args:get-arg "-setlog")
            (args:get-arg "-m"))

	       (else (exit 3)))))
     )

)

(import megatest-main)
(import commonmod)
(make-and-init-bigdata)
(main)