Megatest

;; (declare (uses dcommon))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2015

Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -runall                 : run all tests or as specified by -testpatt
  -remove-runs            : remove the data for a run, requires -runname and -testpatt
                            Optionally use :state and :status
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs

Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
  -target key1/key2/...   : run for key1, key2, etc.
  -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfig
  -testpatt patt1/patt2,patt3/...  : % is wildcard
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context
  -status                 : Applies to runs, tests or steps depending on context
  --modepatt key          : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
  -tagexpr tag1,tag2%,..  : select tests with tags matching expression

Test helpers (for use inside tests)
  -step stepname
  -test-status            : set the state and status of a test (use :state and :status)
  -setlog logfname        : set the path/filename to the final log relative to the test
                            directory. may be used with -test-status
  -set-toplog logfname    : set the overall log for a suite of sub-tests

                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)
  -archive cmd            : archive runs specified by selectors to one of disks specified
                            in the [archive-disks] section.
                            cmd: keep-html, restore, save, save-remove
  -generate-html          : create a simple html tree for browsing your runs

Diff report
  -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
                                                  and either -diff-email or -diff-html)
  -src-target <target>
  -src-runname <target>
  -diff-email <emails>    : comma separated list of email addresses to send diff report
  -diff-html  <rep.html>  : path to html file to generate

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style
Getting started

			":runname"
			"-runname"
			":state"  
			"-state"
			":status"
			"-status"
			"-list-runs"
			"-testpatt"
                        "--modepatt"
                        "-tagexpr"
			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"

			"-archive"
			"-since"
			"-fields"
			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
			"-sort"
			"-target-db"
			"-source-db"

                        "-src-target"
                        "-src-runname"
                        "-diff-email"
                        "-diff-html"
			)
 		 (list  "-h" "-help" "--help"
			"-manual"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"

			"-convert-to-old"
			"-import-megatest.db"
			"-sync-to-megatest.db"

			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only

                        "-diff-rep"
                        )
		 args:arg-hash
		 0))

;; Add args that use remargs here
;;
(if (and (not (null? remargs))
	 (not (or

(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 *watchdog* (make-thread common:watchdog "Watchdog thread"))

(if (not (args:get-arg "-server"))
    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog

;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath)
  (condition-case
   (let* ((log-dir (or (pathname-directory logpath) ".")))
     (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)
        (define *didsomething* #t)  
        (exit 1))))

    
(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
    (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server
	   (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
		     (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
	   (oup  (open-logfile logf)))
      (if (not (args:get-arg "-log"))
	  (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
      (debug:print-info 0 *default-log-port* "Sending log output to " logf)
      (set! *default-log-port* oup)))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")
	(args:get-arg "--help"))
    (begin
      (print help)

	    (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=star-end")))))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================



;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup))


          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))


      (server:launch 0 transport-type)
      (set! *didsomething* #t)))





























(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server")
        (args:get-arg "-kill-server"))
    (let ((tl (launch:setup)))
      (if tl 
	  (let* ((tdbdat  (tasks:open-db))

(if (args:get-arg "-update-meta")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))


      (runs:update-all-test_meta #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Start a repl
;;======================================================================

;; fakeout readline
(include "readline-fix.scm")


(when (args:get-arg "-diff-rep")
  (when (and
         (not (args:get-arg "-diff-html"))
         (not (args:get-arg "-diff-email")))
    (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
    (set! *didsomething* 1)
    (exit 1))
  
  (let* ((toppath (launch:setup)))
    (do-diff-report
     (args:get-arg "-src-target")
     (args:get-arg "-src-runname")
     (args:get-arg "-target")
     (args:get-arg "-runname")
     (args:get-arg "-diff-html")
     (args:get-arg "-diff-email"))
    (set! *didsomething* #t)
    (exit 0)))

(if (or (getenv "MT_RUNSCRIPT")
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstruct (if (and toppath
                              (common:on-homehost?))
                         (db:setup)

       'new2old
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-generate-html")
    (let* ((toppath (launch:setup)))
      (if (tests:create-html-tree #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

;;======================================================================
;; Exit and clean up
;;======================================================================



(if (not *didsomething*)
    (debug:print 0 *default-log-port* help))
;;(BB> "thread-join! watchdog")

;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
(if (thread? *watchdog*)
    (case (thread-state *watchdog*)
      ((ready running blocked sleeping terminated dead)
       (thread-join! *watchdog*))))

(set! *time-to-exit* #t)


(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))