Megatest

           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm filedb.scm tdb.scm client.scm mt.scm	\
           ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm		\
           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)

%.import.o : %.import.scm mofiles/%.o
	csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o

# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
# mofiles/%.o  %.import.scm : %.scm megatest-fossil-hash.scm
#	@[ -e mofiles ] || mkdir -p mofiles
#	csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
#	cp $*.o mofiles/$*.o


# ensure import.scm is touched after the .o is made
#
mofiles/%.o %.import.scm : %.scm

	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
	@touch $*.import.scm

ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')

ifeq ($(MTESTHASH),)

	tests.o \
	subrun.o \
        ezsteps.o

#        mofiles/rmtmod.o \
#        mofiles/commonmod.o \

tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOIMPFILES) $(MOFILES)
	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
	mkdir -p $(PREFIX)/share/docs
	$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
	for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done

# add a fake dependency so this doens't copy everytime
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout
	mkdir -p $(PREFIX)/share/js
	fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js

$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
	mkdir -p $(PREFIX)/share/db
	$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql

# Special dependencies for the module includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
megatest.o : $(MOIMPFILES)
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/dbmod.o mofiles/servermod.o mofiles/apimod.o : mofiles/commonmod.o
mofiles/rmtmod.o : mofiles/apimod.o
common.o : mofiles/commonmod.o
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm

tests.o db.o launch.o runs.o dashboard-tests.o				\
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

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

;;======================================================================

(declare (unit apimod))
(declare (uses commonmod))
;; (declare (uses ulex))

(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
;; (import (prefix ulex ulex:))


(define (api:execute-requests params)
  #f)

)

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)

(declare (unit archive))
(declare (uses db))
(declare (uses common))

(declare (uses commonmod))
(import commonmod)

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

;;======================================================================
;; 
;;======================================================================

     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.

(declare (uses commonmod))
(import commonmod)

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

;; client:get-signature
(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*

     matchable regex posix (srfi 18) extras ;; tcp 
     (prefix nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     pkts (prefix dbi dbi:)
     )

(declare (unit common))
(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")


;; (require-library margs)
;; (include "margs.scm")

;; (define old-exit exit)
;; 
;; (define (exit . code)
;;   (if (null? code)
;;       (old-exit)
;;       (old-exit code)))

(define (common:debug-setup)
  (debug:setup (cond ;; debug arg
		((args:get-arg "-debug-noprop") 'noprop)
		((args:get-arg "-debug")         #t)
		(else #f))
	       (cond ;; verbosity arg
		((args:get-arg "-q") 'v)
		((args:get-arg "-q") 'q)
		(else #f))))

;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)
  (handle-exceptions
   exn
   (begin

    (6 "CHECK")
    (7 "STUCK/DEAD")
    (8 "DEAD")
    (9 "FAIL")
    (10 "PREQ_FAIL")
    (11 "PREQ_DISCARDED")
    (12 "ABORT")))

(define (common:status>? s1 s2)
  (let* ((munged (map (lambda (x) `(,(cadr x) . ,(car x))) *common:std-statuses*))
	 (v1     (alist-ref s1 munged equal?))
	 (v2     (alist-ref s2 munged equal?)))
    (> v1 v2)))

(define *common:ended-states*       ;; states which indicate the test is stopped and will not proceed
  '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))

(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
  '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))

;;
(define-inline (with-mutex mtx accessor record . val)
  (mutex-lock! mtx)
  (let ((res (apply accessor record val)))
    (mutex-unlock! mtx)
    res))

;; ;; this was cached based on results from profiling but it turned out the profiling
;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; ;; in for now but can probably take it out later.
;; ;;
;; (define (debug:calc-verbosity vstr)
;;   (or (hash-table-ref/default *verbosity-cache* vstr #f)
;;       (let ((res (cond
;;                   ((number? vstr) vstr)
;;                   ((not (string?  vstr))   1)
;;                   ;; ((string-match  "^\\s*$" vstr) 1)
;;                   (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
;;                                     (cond
;;                                      ((> (length debugvals) 1) debugvals)
;;                                      ((> (length debugvals) 0)(car debugvals))
;;                                      (else 1))))
;;                   ((args:get-arg "-v")   2)
;;                   ((args:get-arg "-q")    0)
;;                   (else                   1))))
;;         (hash-table-set! *verbosity-cache* vstr res)
;;         res)))
;; 

















;; ;; 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))))
;; 
;; (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))
;;     (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*))))))
;;   
;; (define (debug:print n e . params)
;;   (if (debug:debug-mode n)
;;       (with-output-to-port (or e (current-error-port))
;; 	(lambda ()
;; 	  (if *logging*
;; 	      (db:log-event (apply conc params))
;; 	      (apply print params)
;; 	      )))))
;; 
;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;;   (let* ((stack (get-call-chain))
;;          (location "??"))
;;     (for-each
;;      (lambda (frame)
;;        (let* ((this-loc (vector-ref frame 0))
;;               (temp     (string-split (->string this-loc) " "))
;;               (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;;          (if (equal? this-func "BB>")
;;              (set! location this-loc))))
;;      stack)
;;     (let* ((color-on "\x1b[1m")
;;            (color-off "\x1b[0m")
;;            (dp-args
;;             (append
;;              (list 0 *default-log-port*
;;                    (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
;;              in-args)))
;;       (apply debug:print dp-args))))
;; 
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;; 
;; 
;; 
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;;                  (cons hash-table? hash-table->alist))
;; 
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;;   (let ((res #f))
;;     (for-each
;;      (lambda (custom-type-name)
;;        (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;;               (custom-type-test      (car custom-type-info))
;;               (custom-type-converter (cdr custom-type-info)))
;;          (when (and (not res) (custom-type-test arg))
;;            (set! res (custom-type-converter arg)))))
;;      (hash-table-keys *BBpp_custom_expanders_list*))
;;     (if res (BBpp_ res) arg)))
;; 
;; (define (BBpp_ arg)
;;   (cond
;;    ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;    ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;;    ((hash-table? arg)
;;     (let ((al (hash-table->alist arg)))
;;       (BBpp_ (cons HASH_TABLE: al))))
;;    ((null? arg) '())
;;    ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    (else (BBpp_custom_converter arg))))
;; 
;; ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;;   (pp (BBpp_ arg)))
;; 
;; ;(use define-macro)
;; (define-syntax inspect
;;   (syntax-rules ()
;;     [(_ x)
;;     ;; (with-output-to-port (current-error-port)
;;        (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;;      ;;  )
;;      ]

;;     [(_ x y ...) (begin (inspect x) (inspect y ...))]))
;; 
;; (define (debug:print-error n e . params)
;;   ;; normal print
;;   (if (debug:debug-mode n)
;;       (with-output-to-port (if (port? e) e (current-error-port))
;; 	(lambda ()
;; 	  (if *logging*
;; 	      (db:log-event (apply conc params))
;; 	      ;; (apply print "pid:" (current-process-id) " " params)
;; 	      (apply print "ERROR: " params)
;; 	      ))))
;;   ;; pass important messages to stderr
;;   (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
;;       (with-output-to-port (current-error-port)
;; 	(lambda ()
;; 	  (apply print "ERROR: " params)
;; 	  ))))
;; 
;; (define (debug:print-info n e . params)
;;   (if (debug:debug-mode n)
;;       (with-output-to-port (if (port? e) e (current-error-port))
;; 	(lambda ()
;; 	  (if *logging*
;; 	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
;; 		(db:log-event res))
;; 	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
;; 	      (apply print "INFO: (" n ") " params) ;; res)
;; 	      )))))
;; 


;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

;;======================================================================

(declare (unit commonmod))

(module commonmod
	*
	
(import scheme chicken data-structures extras files ports)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1
	format)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites

;;
(define (get-cfg-areas cfgdat)
  (let ((adat (get-section cfgdat "areas")))
    (map (lambda (entry)
	   `(,(car entry) . 
	     ,(val->alist (cadr entry))))
	 adat)))

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
	 
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
  (let* ((res (cond
	       ((number? vstr) vstr)
	       ((not (string?  vstr))   1)
	       ;; ((string-match  "^\\s*$" vstr) 1)
	       (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
				 (cond
				  ((> (length debugvals) 1) debugvals)
				  ((> (length debugvals) 0)(car debugvals))
				  (else 1))))
	       ((eq? arg 'v)   2) ;; verbose
	       ((eq? arg 'q)   0) ;; quiet
	       (else                   1))))
    (verbosity res)
    res))

;; 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)
  (let* ((vb (verbosity)))
    (cond
   ((and (number? vb)   ;; number number
	 (number? n))
    (<= n vb))
   ((and (list? vb)     ;; list   number
	 (number? n))
    (member n vb))
   ((and (list? vb)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? vb n))))
   ((and (number? vb)
	 (list? n))
    (member vb n)))))

(define (debug:setup debug-arg verbose-arg) ;; debug-arg= #f, #t or 'noprop
  (let ((debugstr (or debug-arg ;; (args:get-arg "-debug")
		      ;; (args:get-arg "-debug-noprop")
		      (get-environment-variable "MT_DEBUG_MODE"))))
    (debug:calc-verbosity debugstr verbose-arg)
    ;; (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 (eq? debug-arg 'noprop))
	     (or debug-arg
		 (not (get-environment-variable "MT_DEBUG_MODE"))))
	(setenv "MT_DEBUG_MODE" (if (list? (verbosity))
				    (string-intersperse (map conc (verbosity)) ",")
				    (conc (verbosity)))))))

(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print params)
	  )))) ;; )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " params)
	  )))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") " params) ;; res)
	  ))))

)

;;======================================================================

(use regex regex-case matchable) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))

(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))

(declare (uses commonmod))
(import commonmod)

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

(define (dboard:launch-testpanel run-id test-id)
  (let* ((dboardexe (common:find-local-megatest "dashboard"))

(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))

(declare (uses commonmod))
(import commonmod)

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

(define (control-panel db tdb keys)

(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))

(declare (uses commonmod))
(import commonmod)

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

;;======================================================================
;; C O M M O N

(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
;; (include "megatest-fossil-hash.scm")
(include "vg_records.scm")

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2017

  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
;; (hash-table-set! *BBpp_custom_expanders_list* TABDAT:
;;                  (cons dboard:tabdat?
;;                        (lambda (tabdat-item)
;;                          (filter
;;                           (lambda (alist-entry)
;;                             (member (car alist-entry)
;;                                     '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
;;                           (dboard:tabdat->alist tabdat-item)))))



(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
;; (hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
;;                  (cons dboard:rundat?
;;                        (lambda (tabdat-item)
;;                          (filter
;;                           (lambda (alist-entry)
;;                             (member (car alist-entry)
;;                                     '(run run-data-offset ))) ;; FIELDS OF INTEREST
;;                           (dboard:rundat->alist tabdat-item)))))




(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
  (make-dboard:rundat 
   run: run

    (if t-sort
	(cadr t-sort)
	3)))

(define (get-curr-sort)
  (vector-ref *tests-sort-options* *tests-sort-reverse*))

(common:debug-setup)

;; (define uidat #f)

(define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))

(declare (uses commonmod))
(import commonmod)

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

(define *number-of-writes* 0)

(import canvas-draw-iup)
(use regex typed-records matchable)

(declare (unit dcommon))

(declare (uses gutils))
(declare (uses db))

(declare (uses commonmod))
(import commonmod)

;; (declare (uses synchash))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

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

(declare (unit diff-report))
(declare (uses common))
(declare (uses rmt))
         
(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")

(define (diff:tests-mindat->hash tests-mindat)

all : server.ps megatest_manual.html client.ps complex-itemmap.png megatest_manual.pdf

megatest_manual.html : megatest_manual.txt  *.txt installation.txt *png
	asciidoc  -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt
#	dos2unix megatest_manual.html

megatest_manual.pdf : megatest_manual.txt *.txt *png *.ps
	a2x -a toc -f pdf megatest_manual.txt

server.pdf : server.dot
	dot -Tpdf server.dot > server.pdf

server.ps : server.dot
	dot -Tps server.dot > server.ps

client.ps : client.dot
	dot -Tps client.dot > client.ps

complex-itemmap.png : complex-itemmap.dot

<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<meta name="generator" content="AsciiDoc 8.6.10">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;

ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

.monospaced, code, pre {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
  padding: 0;
  margin: 0;
}
pre {
  white-space: pre-wrap;
}

#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {

div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; vertical-align: text-bottom; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {

/*
 * xhtml11 specific
 *
 * */







div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}

/*
 * html5 specific
 *
 * */







table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;

body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


@media screen {
  body {
    max-width: 50em; /* approximately 80 characters wide */
    margin-left: 16em;
  }

  #toc {

</div></div>
</div>
<div class="sect2">
<h3 id="_trim_trailing_spaces">Trim trailing spaces</h3>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.</td>
</tr></table>
</div>
<div class="listingblock">
<div class="content monospaced">
<pre>[configf:settings trim-trailing-spaces no]

<pre># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">Dynamic waiton lists must be capable of being calculated at the
beginning of a run. This is because Megatest walks the tree of waitons
to create the list of tests to execute.</td>
</tr></table>
</div>
<div class="listingblock">

<div class="content monospaced">
<pre>[triggers]
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the double-dash</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and

</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.5<br>
Last updated
 2021-01-25 11:33:16 MST
</div>
</div>
</body>
</html>

//     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
//     GNU General Public License for more details.
// 
//     You should have received a copy of the GNU General Public License
//     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
digraph G {

// connecting to server
subgraph cluster_1 {
  label="Connect";
  
  node [style=filled,shape=box];
  dotserver [label="Have .server file?"];
  connect [label="Connect to server"];
  // startserver [label="Start Server"];
  connected [label="Connection Successful"];
  anylive [label="Any live servers?"];
  askstart [label="Ask existing server to start a new server"];
  anydboard [label="Any live dashboards"];
  askdboard [label="Ask dashboard to start server"];
  serverlaunch [label="User server launch to start server process"];
  wait5sec [label="Wait 5 seconds"];
  

  dotserver -> connect [label="yes"];
  connect -> connected [label="yes"];
  connect -> anylive [label="no"];

  // startserver -> anylive;
  anylive -> askstart [label="yes"];
  anylive -> anydboard [label="no"];
  anydboard -> askdboard [label="yes"];
  anydboard -> serverlaunch [label="no"];
  serverlaunch -> wait5sec;
  askdboard -> wait5sec;
  askstart -> wait5sec;
  wait5sec -> dotserver;



}



// server bootstrap
subgraph cluster_2 {
  label="Startup";
  node [style=filled,shape=box];
  getlock [label="Get file lock"];
  starthttpcpdb [label="Start http server/copy db to /tmp"];
  createsrvfile [label="Create .nnn.server file containing host:port"];
  releaselock [label="Release file lock"];
  chksrv [label="Check if server already exists"];
  exitstartup [label="exit/stop"];
  sleep1 [label="Sleep few seconds"];
  

  getlock -> starthttpcpdb [label="yes"];
  getlock -> chksrv [label="no"];
  starthttpcpdb -> createsrvfile -> releaselock;
  chksrv -> exitstartup [label="yes"];
  chksrv -> sleep1 [label="no"];
  sleep1 -> getlock;
}

// shutting down server
subgraph cluster_3 {
  label="Shutdown";
  node [style=filled,shape=box];
  shutdown [label="Start Shutdown"];
  rejectmode [label="Put http server into reject requests mode"];
  syncback [label="Sync db back"];
  removesrvfile [label="Remove server file containing host:port"];
  exit [label="Exit process"];

  shutdown -> rejectmode -> syncback -> removesrvfile -> exit;
}

//     subgraph cluster_1 {
//         node [style=filled,shape=box];
// 
// 	check_available_queue       -> remove_entries_over_10s_old;
// 	remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
// 	remove_entries_over_10s_old -> exit [label="num_avail > 2"];
// 
// 	set_available               -> delay_2s;
// 	delay_2s          -> check_place_in_queue;
// 
// 	check_place_in_queue        -> "http:transport-launch" [label="at head"];

// 	check_place_in_queue        -> exit [label="not at head"];
// 
// 	"client:login"              -> "server:shutdown" [label="login failed"];
// 	"server:shutdown"           -> exit;	
// 
// 	subgraph cluster_2 {
// 		"http:transport-launch"       -> "http:transport-run";
// 		"http:transport-launch"       -> "http:transport-keep-running";
// 
// 		"http:transport-keep-running" -> "tests running?";
// 		"tests running?"              -> "client:login" [label=yes];
// 		"tests running?"              -> "server:shutdown" [label=no];
// 		"client:login"                -> delay_5s [label="login ok"];
// 		delay_5s                      -> "http:transport-keep-running";
// 	}
// 
// 	// start_server -> "server_running?";
// 	// "server_running?" -> set_available [label="no"];
// 	// "server_running?" -> delay_2s [label="yes"];
// 	// delay_2s -> "still_running?";
// 	// "still_running?" -> ping_server [label=yes];
// 	// "still_running?" -> set_available [label=no];
// 	// ping_server -> exit [label=alive];
// 	// ping_server -> remove_server_record [label=dead];
// 	// remove_server_record -> set_available;
// 	// set_available -> avail_delay [label="delay 3s"];
// 	// avail_delay -> "first_in_queue?";
// 	// 
// 	// "first_in_queue?" -> set_running [label=yes];
// 	// set_running -> get_next_port -> handle_requests;
// 	// "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
// 	// "dead_entry_in_queue?" -> "server_running?" [label=no];
// 	// "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
// 	// remove_dead_entries -> "server_running?";
// 	// 
// 	// handle_requests -> start_shutdown [label="no traffic\nno running tests"];
// 	// handle_requests -> shutdown_request;
// 	// start_shutdown -> shutdown_delay;
// 	// shutdown_request -> shutdown_delay;
// 	// shutdown_delay -> exit;
// 	
//         label = "server:launch";
//         color=brown;

//     }

//     client_start_server -> start_server;
//     handle_requests -> read_write;
//     read_write -> handle_requests;
}

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))

(declare (uses commonmod))
(import commonmod)

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

(declare (unit fs-transport))

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

(declare (uses commonmod))
(import commonmod)

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


;;======================================================================
;; F S   T R A N S P O R T   S E R V E R

(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
;; (declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")

(require-library stml)
(define (http-transport:make-server-url hostport)

(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

(declare (uses commonmod))
(import commonmod)

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

;; (define itemdat '((ripeness    "green ripe overripe")
;; 		     (temperature "cool medium hot")
;; 		     (season      "summer winter fall spring")))

(declare (unit items))
(declare (uses common))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)

;;======================================================================

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (unit keys))
(declare (uses common))

(declare (uses commonmod))
(import commonmod)

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

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

;;======================================================================

(use (prefix sqlite3 sqlite3:) srfi-18)

(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))

(declare (uses commonmod))
(import commonmod)
;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================

;;======================================================================
;; db record, <vector db path-to-db>

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

;; Needed for repl even if not used here in megatest.scm
(declare (uses commonmod))
(import commonmod)
(declare (uses commonmod.import))

(declare (uses dbmod))
(import dbmod)
(declare (uses dbmod.import))

(declare (uses servermod))
(import servermod)
(declare (uses servermod.import))

(declare (uses apimod))
(import apimod)
(declare (uses apimod.import))

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

			"-mark-incompletes"

			"-convert-to-norm"
			"-convert-to-old"
			"-import-megatest.db"
			"-sync-to-megatest.db"
                        "-sync-brute-force"
			;; "-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only

                        "-diff-rep"

			"-syscheck"
			"-obfuscate"

		   (exit 1))))
	   homehost-required))))

;;======================================================================
;; Misc setup stuff
;;======================================================================

(common:debug-setup)

;; (if (args:get-arg "-logging")(set! *logging* #t))

;;(if (debug:debug-mode 3) ;; we are obviously debugging
;;    (set! open-run-close open-run-close-no-exception-handling))

(if (args:get-arg "-itempatt")
    (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
      (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)

Built modules go here - an attempt to minimize clutter.

(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))

(declare (uses commonmod))
(import commonmod)

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

     (prefix sqlite3 sqlite3:)
     nanomsg)

(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))

(declare (uses commonmod))
(import commonmod)

(use ducttape-lib)

(include "megatest-fossil-hash.scm")

(require-library stml)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
     (prefix dbi dbi:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))

(declare (uses commonmod))
(import commonmod)

;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))

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

(use csv-xml regex)
(declare (unit ods))
(declare (uses common))
(declare (uses commonmod))
(import commonmod)

(define ods:dirs
  '("Configurations2"
    "Configurations2/toolpanel"
    "Configurations2/menubar"
    "Configurations2/toolbar"
    "Configurations2/progressbar"

;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))

(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
;; (declare (uses rmtmod))

;; (import rmtmod)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!

;;======================================================================

(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses apimod))
;; (declare (uses apimod.import))
;; (declare (uses ulex))

;; (include "ulex/ulex.scm")

(module rmtmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import (prefix commonmod cmod:))
(import apimod)
;; (import (prefix ulex ulex:))

(defstruct alldat
  (areapath #f)
  (ulexdat  #f)
  )

;; return the handle struct for sending queries to a specific database

;; to this run field1val/field2val/field3val ...
;;======================================================================

(use format directory-utils)

(declare (unit runconfig))
(declare (uses common))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")

(define (runconfig:read fname target environ-patt)
  (let ((ht (make-hash-table)))
    (if target (hash-table-set! ht target '()))
    (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))

(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))

(declare (uses commonmod))
(import commonmod)

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

(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses synchash))
(declare (uses http-transport))
;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))

(declare (uses commonmod))
(import commonmod)

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

(define (server:make-server-url hostport)
  (if (not hostport)
      #f

;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit servermod))

(module servermod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)

(define (just-testing)
  (print "JUST TESTING"))

;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

)

;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))

(declare (uses commonmod))
(import commonmod)

;;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

(define (subrun:subrun-test-initialized? test-run-dir)
  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )

(declare (unit tasks))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))

;; (import pgdb) ;; pgdb is a module

(declare (uses commonmod))
(import commonmod)

(include "task_records.scm")
(include "db_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================

(use trace)
;; (trace-call-sites #t)

(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
;; (declare (uses megatest-version))

(declare (uses commonmod))
(import commonmod)

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "db_records.scm")

(define origargs (cdr (argv)))
(define remargs (args:get-args

(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(declare (uses db))

(declare (uses commonmod))
(import commonmod)

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

;;======================================================================

;; (declare (uses sdb))
(declare (uses server))
;;(declare (uses stml2))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")

(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))

(declare (uses commonmod))
(import commonmod)


(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")

;;======================================================================