Megatest

           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm pgdb.scm

#  cgisetup/models/pgdb.scm

# module source files
MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \
           ducttape-lib.scm pkts.scm dbi.scm autoload.scm stml2.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)

TMPMODS = $(SRCFILES:%.scm=tmpmods/%.scm)
OTMPMODS = $(SRCFILES:%.scm=tmpmods/%.o)

tmpmods/%.scm : %.scm utils/makemodulewrap.sh
	./utils/makemodulewrap.sh $*

tmpmods/%.o : tmpmods/%.scm
	csc $(CSCOPTS) -J -c $< -o tmpmods/$*.o

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

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

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
	echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
	if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi

$(OFILES) $(GOFILES) : common_records.scm 

%.o : %.scm $(MOFILES) tmpmods/%.o
	csc $(CSCOPTS) -c $< $(MOFILES)

$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
	@echo Installing to PREFIX=$(PREFIX)
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

;;     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/>.
;;
;;======================================================================

(import srfi-69
	;; posix
	chicken.process-context.posix
	chicken.time
	chicken.string
	)

(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))

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

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

(import
 (prefix sqlite3 sqlite3:) srfi-1
 ;; posix
 regex regex-case srfi-69 format md5 message-digest srfi-18
 srfi-13
 
 chicken.file
 chicken.io
 chicken.pathname
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.string
 chicken.time
 chicken.time.posix
 chicken.condition

 )

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

(include "common_records.scm")
(include "db_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 pgdb))


(import
  chicken.sort
  chicken.string
  srfi-1
  srfi-69
  chicken.condition
  typed-records
  )

;; (declare (uses configf))
;; 
;; ;; I don't know how to mix compilation units and modules, so no module here.
;; ;;
;; ;; (module pgdb
;; ;;     (
;; ;;      open-pgdb

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

;;======================================================================
;; C L I E N T S
;;======================================================================

(import srfi-18
	;; extras tcp s11n
	srfi-1
	;; posix
	regex srfi-69
	;; hostinfo
	md5
	message-digest matchable spiffy uri-common intarweb http-client
	spiffy-request-vars uri-common intarweb
	;; directory-utils)
  chicken.port
  chicken.pretty-print
  chicken.process-context.posix
  chicken.string
  chicken.time
  system-information

	)

(declare (unit client))

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

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

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(import srfi-69)
(import matchable)
(import utils)
(import ports)
(import extras)
(import srfi-1)
(import posix)
(import srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()

;;     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 common))
(declare (uses commonmod))
(declare (uses pkts))
(declare (uses dbi))

(import
 srfi-1
 srfi-69
 ;; data-structures posix
 regex-case (prefix base64 base64:)
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.format
 chicken.io
 chicken.pathname
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.process.signal
 chicken.string
 chicken.sort
 chicken.time
 chicken.time.posix
 
 ;; dot-locking
 ;; csv-xml
 z3
 ;; udp ;; sql-de-lite
 ;; hostinfo
 md5
 message-digest typed-records
 ;; directory-utils
 sparse-vectors
 stack
 matchable regex
 ;; posix
 (srfi 18)
 srfi-13

 system-information
 ;; extras ;; tcp 
 (prefix nanomsg nmsg:)
 (prefix sqlite3 sqlite3:)
 pkts
 (prefix dbi dbi:)
 )

;; (import posix-extras pathname-expand files)


(import commonmod)

(include "common_records.scm")

(define setenv set-environment-variable!)
;; (require-library margs)
;; (include "margs.scm")

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

(define *launch-setup-mutex* (make-mutex))     ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex*     (make-mutex))

;; Miscellaneous
(define *triggers-mutex*     (make-mutex))     ;; block overlapping processing of triggers
(define *numcpus-cache* (make-hash-table))



;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
#;(let-values (( (chicken-release-number chicken-major-version)
               (apply values
                      (map string->number
                           (take
                            (string-split (chicken-version) ".")
                            2)))))
  (let ((resolve-pathname-broken?
         (or (> chicken-release-number 4)
             (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
    (if resolve-pathname-broken?
        (define ##sys#expand-home-path pathname-expand))))
      
;; (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))

(define (common:get-this-exe-fullpath #!key (argv (argv)))
  (let* ((this-script
          (cond
           ((and (> (length argv) 2)
                 (string-match "^(.*/csi|csi)$" (car argv))
                 (string-match "^-(s|ss|sx|script)$" (cadr argv)))

;;     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/>.
;;
;;======================================================================

;; (import trace)

(include "altdb.scm")

;; Some of these routines use:
;;
;;     http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;

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

;(import 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))))
     ;;  )
     ]

;;     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 commonmod))

(import srfi-69)

(module commonmod
	*

	(import
	 scheme
	 chicken.base

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

;;======================================================================
;; Config file handling
;;======================================================================


(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))

(import
 regex regex-case matchable
 chicken.condition
 chicken.file
 chicken.io
 chicken.pathname
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.sort
 chicken.string
 chicken.time
 srfi-1
 srfi-13
 srfi-69
)	

(include "common_records.scm")

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

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

;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================

(import format fmt)
(require-library iup)
(import (prefix iup iup:))

(import canvas-draw)

(import
 srfi-1
 ;; posix
 regex regex-case srfi-69

chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.string
chicken.time
chicken.condition
chicken.process-context

 )

(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))

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

;;======================================================================
;; Test info panel
;;======================================================================

(import format)
(require-library iup)
(import (prefix iup iup:))

(import canvas-draw)

(import sqlite3 srfi-1
	;; posix
	regex regex-case srfi-69)

(import
 (prefix sqlite3 sqlite3:)

 chicken.file.posix
 chicken.port
 chicken.pretty-print
 chicken.string
 chicken.time
 
	
)
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))

(include "common_records.scm")

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

;;======================================================================
;; Test info panel
;;======================================================================

(import format fmt)
(require-library iup)
(import (prefix iup iup:))

(import canvas-draw)

(import
 srfi-1
 ;; posix
 regex regex-case srfi-69
 chicken.file
 chicken.file.posix
 chicken.port
 chicken.pretty-print
 chicken.string
 chicken.time
 srfi-18
 chicken.condition
 chicken.process-context
 
)
	
(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))

;;     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/>.
;;
;;======================================================================

(import format)

(require-library iup)
(import (prefix iup iup:))

(import canvas-draw)
(import canvas-draw-iup)
(import ducttape-lib)
(import
 sqlite3 srfi-1
 ;; posix
 regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(import dbfile)

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))

;;     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/>.

;; ==> (module datashare
;; ==> (import ssax)
;; ==> (import sxml-serializer)
;; ==> (import sxml-modifications)
;; ==> (import regex)
;; ==> (import srfi-69)
;; ==> (import regex-case)
;; ==> (import posix)
;; ==> (import json)
;; ==> (import csv)
;; ==> (import srfi-18)
;; ==> (import format)
;; ==> 
;; ==> (import (prefix iup iup:))
;; ==> (import (prefix ini-file ini:))
;; ==> 
;; ==> (import canvas-draw)
;; ==> (import canvas-draw-iup)
;; ==> 
;; ==> (import sqlite3 srfi-1 posix regex regex-case srfi-69)
;; ==> (import (prefix sqlite3 sqlite3:))
;; ==> 
;; ==> (declare (uses configf))
;; ==> (declare (uses tree))
;; ==> (declare (uses margs))
;; ==> ;; (declare (uses dcommon))
;; ==> ;; (declare (uses launch))

;;======================================================================
;; Database access
;;======================================================================

;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc

(import
 (srfi 18)
 ;; extras
 ;; tcp
 stack
 (prefix sqlite3 sqlite3:)
 srfi-1
 ;; posix
 regex
 regex-case
 srfi-69
 ;; csv-xml
 s11n
 md5
 message-digest
 (prefix base64 base64:)
 ;; format
 ;; dot-locking
 z3
 typed-records
 matchable
 ;; files
 srfi-13
 
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.format
 chicken.io
 chicken.pathname
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.sort
 chicken.string
 chicken.time
 chicken.time.posix



 )

(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))

;;     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/>.
;;
;;======================================================================

(import format)
(require-library iup)
(import (prefix iup iup:))
(import canvas-draw)
(import canvas-draw-iup)
(import regex typed-records matchable

  chicken.condition
  chicken.file
  chicken.file.posix
  chicken.port
  chicken.pretty-print
  chicken.process
  chicken.process-context
  chicken.process-context.posix
  chicken.sort
  chicken.string
  chicken.time
  srfi-1
  srfi-18
  srfi-69
	
  )

(declare (unit dcommon))

(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))

;;

(declare (unit diff-report))
(declare (uses common))
(declare (uses rmt))
(declare (uses ducttape-lib))
         

(import
 matchable
 fmt
 ducttape-lib

 chicken.port
 chicken.pretty-print
 chicken.sort
 chicken.string
 chicken.time
 chicken.time.posix
 srfi-1
 srfi-69
 srfi-13

 )

(include "common_records.scm")

(define css "")

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)

;;     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 env))

(import
 sql-de-lite ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
chicken.string
srfi-1
srfi-69
chicken.process-context
)	

(define (env:open-db fname)
  (let* ((db-exists (common:file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (

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

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

(import
 srfi-1
 ;; posix regex srfi-69
 ;; directory-utils
 ;; call-with-environment-variables posix-extras
 z3
 ;; csv
 typed-records pathname-expand matchable
 chicken.file
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.string
 chicken.time
 srfi-18
 srfi-69
 chicken.process-context
 regex
 )

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

;;     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/>.
;;
(import foof-loop sql-de-lite posix)

(define beginning-2016 1451636435.0)
(define now (current-seconds))
(define one-year-ago (- now (* 365 24 60 60)))

(define db (open-database "example.db"))

;; 
;;     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 genexample))
(import
 regex matchable
 chicken.file
 chicken.file.posix
 chicken.io
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.string
 srfi-1
 srfi-69
 srfi-13
	)

(include "db_records.scm")

(define genexample:example-logpro
#<<EOF
  ;; You should have at least one expect:required. This ensures that your process ran
  ;; comment out the line below and replace "put pattern here" with a pattern that will

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

(require-library iup)
(import (prefix iup iup:))
(import canvas-draw)

(import
 srfi-1 regex regex-case srfi-69
 chicken.string
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.sort
 chicken.string
 chicken.time
 srfi-1 
 srfi-18
 srfi-69
 )
	
(declare (unit gutils))

;; NOTE: These functions will move to iuputils

(define (gutils:colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))

 srfi-1
 ;; posix
 regex regex-case srfi-69
 ;; hostinfo
 md5 message-digest
 ;;posix-extras

 spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing
 
chicken.condition
chicken.file
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.string
chicken.time
chicken.time.posix
system-information
srfi-13
chicken.io

 )

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

(declare (unit http-transport))

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

(import dbfile commonmod)

(require-library stml)

(define setenv set-environment-variable!)
(define getenv get-environment-variable)

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))

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

;;======================================================================
;; Tests
;;======================================================================

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

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

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

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

(import
 chicken.file
 chicken.io
 chicken.port
 chicken.pretty-print
 chicken.string
 chicken.time
 chicken.process-context
 srfi-1
 srfi-69)


(include "common_records.scm")
(define setenv set-environment-variable!)
(define getenv get-environment-variable)

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

(import sqlite3 srfi-1
	;; posix
	regex regex-case srfi-69 (prefix sqlite3 sqlite3:)
 chicken.port
 chicken.pretty-print
 chicken.string
 chicken.time
 srfi-13
)

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

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

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

;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================

(import
 chicken.bitwise
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.io
 chicken.pathname
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.process.signal
 chicken.sort
 chicken.string
 chicken.time
 srfi-1
 srfi-69
 system-information

 regex regex-case base64 sqlite3 srfi-18 directory-utils
 ;; posix-extras
 z3
 ;; call-with-environment-variables csv)
 typed-records pathname-expand matchable)

(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

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

(define getenv get-environment-variable)
(define setenv set-environment-variable!)

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

;;======================================================================
;; ezsteps

;;     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/>.
;;

(import
 (prefix sqlite3 sqlite3:) srfi-18
 chicken.file
 chicken.process
 chicken.time
 sqlite3
 chicken.condition
 chicken.string
	)

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

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing

				(begin
				  (thread-sleep! 1)
				  (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
	     (sqlite3:finalize! db)
	     result))))))
	  
            
;; (import trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)

;; 
;;     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 margs))
;; (declare (uses common))

(import chicken.process-context
	srfi-1
	srfi-69
	)

(define args:arg-hash (make-hash-table))

(define (args:get-arg arg . default)
  (if (null? default)
      (hash-table-ref/default args:arg-hash arg #f)
      (hash-table-ref/default args:arg-hash arg (car default))))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	commonmod
	dbfile)

(import
chicken.condition
  chicken.file
  chicken.pathname
  chicken.port
  chicken.pretty-print
  chicken.process
  chicken.process-context
  chicken.process-context.posix
  chicken.process.signal
  chicken.repl
  chicken.sort
  chicken.string
  chicken.time
  chicken.time.posix
  srfi-1
  srfi-13
  srfi-69
  system-information
 
 )

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

(require-library mutils)

(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

(dbfile:db-init-proc db:initialize-main-db)

;; load the ~/.megatestrc file, put (import 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!
;;

  -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 (import :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
  -summarize-items        : for an itemized test create a summary html 
  -m comment              : insert a comment for this test

Test data capture

  -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            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, get, replicate-db (import 
                            -dest to set destination), -include path1,path2... to get or save specific files
  -generate-html          : create a simple html dashboard for browsing your runs
  -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
  -list-run-time          : list time requered to complete runs. It supports following switches
                            -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
  -list-test-time	  : list time requered to complete each test in a run. It following following arguments
                            -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>

;; MLAUNCH
;;
;;   take jobs from the given queue and keep launching them keeping
;;   the cpu load at the targeted level
;;
;;======================================================================

(import sqlite3 srfi-1 posix regex regex-case srfi-69 format)

(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))

;;     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/>.

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

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

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

;;     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/>.
;;


(import sqlite3 srfi-1
	;; posix
	regex regex-case srfi-69
	;; dot-locking
	(srfi 18)
	;; posix-extras directory-utils call-with-environment-variables
  chicken.file
  chicken.port
  chicken.pretty-print
  chicken.process
  chicken.process-context.posix
  chicken.string
  chicken.time
  chicken.condition
  chicken.process-context
  )
(import (prefix sqlite3 sqlite3:))

(declare (unit mt))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

 )

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

;; (import ducttape-lib)
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

;; (require-library stml)

(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest

 chicken.format
 pkts regex regex-case
 (prefix dbi dbi:)
 (prefix sqlite3 sqlite3:)
 nanomsg)


(import ducttape-lib)

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

(require-library stml)

;; stuff for the mapper and checker functions
;;

                   extra-dat: `(a ,runkey)  ;; we need the run key for marking the run as launched
                   )))
      (with-output-to-file
	  (conc pktsdir "/" uuid ".pkt")
	(lambda ()
	  (print pkt))))))

;; (import trace)(trace create-run-pkt)
(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
        (packets-generated 0))

	  (conc "megatest " (if (not (member action '("sync")))
				(conc action " " action-param)
				"") (if (member action '("-run" "-rerun-clean" "-rerun-all" "-kill-rerun"))
                                                        "-rerun DEAD,ABORT,KILLED"
                                                        ""))
	  pkta)))

;; (import trace)(trace pkt->cmdline)

(define (write-pkt pktsdir uuid pkt)
  (if pktsdir
      (with-output-to-file
	  (conc pktsdir "/" uuid ".pkt")
	(lambda ()
	  (print pkt)))

;;     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/>.

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

(import format)

(import (prefix iup iup:))

(import canvas-draw)
(import canvas-draw-iup)

(import 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 launch))

;;     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/>.
;;

(import ;; csv-xml
 chicken.port
 chicken.process
 chicken.string
 regex
 srfi-13
 )

(declare (unit ods))
(declare (uses common))

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

 srfi-1
 ;; posix
 srfi-69
 ;; hostinfo
 ;; dot-locking
 z3
 (prefix sqlite3 sqlite3:)

chicken.condition
chicken.file
chicken.process
chicken.process-context.posix
chicken.string

 )

(declare (unit portlogger))
(declare (uses db))

;; lsof -i

(define (portlogger:open-db fname)

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

;;======================================================================
;; Process convience utils
;;======================================================================

(import
 regex directory-utils
 chicken.condition
 chicken.file
 chicken.io
 chicken.process
 chicken.process-context.posix
 chicken.string
 srfi-18
)
(declare (unit process))

(define (process:conservative-read port)
  (let loop ((res ""))
    (if (not (eof-object? (peek-char port)))
	(loop (conc res (read-char port)))
	res)))

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

;; (include "vg.scm")

;; (declare (uses vg))

(import foof-loop defstruct coops)

(defstruct obj     type fill-color angle)

(define (make-vg:obj)(make-vector 3))
(define-inline (vg:obj-get-type         vec)    (vector-ref  vec 0))
(define-inline (vg:obj-get-fill-color   vec)    (vector-ref  vec 1))
(define-inline (vg:obj-get-angle        vec)    (vector-ref  vec 2))
(define-inline (vg:obj-set-type!        vec val)(vector-set! vec 0 val))
(define-inline (vg:obj-set-fill-color!  vec val)(vector-set! vec 1 val))
(define-inline (vg:obj-set-angle!       vec val)(vector-set! vec 2 val))

(import simple-exceptions)
(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
(define-inline (vgs:obj-type             vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
(define-inline (vgs:obj-fill-color       vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
(define-inline (vgs:obj-angle            vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
(define-inline (vgs:obj-type-set!        vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
(define-inline (vgs:obj-fill-color-set!  vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))

;;     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/>.
;;
;;======================================================================

(import
 format typed-records
 chicken.condition
 chicken.port
 chicken.pretty-print
 chicken.sort
 chicken.string
 chicken.time
 srfi-1
 srfi-18
 srfi-69

	) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(include "common_records.scm")
;; (declare (uses rmtmod))

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

;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================

(import format directory-utils
	chicken.port
	chicken.pretty-print
	chicken.string
	chicken.time
	srfi-1
	srfi-69
	chicken.process-context)

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

(include "common_records.scm")

(define (runconfig:read fname target environ-patt)

;;     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/>.
;;
(import srfi-69)

(define (runs:queue-next-hed tal reg n regful)
  (if regful
      (car reg)
      (car tal)))

(define (runs:queue-next-tal tal reg n regful)

(define (runs:queue-next-reg tal reg n regful)
  (if regful
      (cdr reg)
      (if (eq? (length tal) 1)
	  '()
	  reg)))

(import trace)
(trace runs:queue-next-hed
       runs:queue-next-tal
       runs:queue-next-reg)


(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))

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

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

(import
 (prefix sqlite3 sqlite3:) srfi-1
 ;; posix
 regex regex-case srfi-69 (srfi 18)
 srfi-13
 ;; posix-extras directory-utils pathname-expand
 typed-records format  sxml-serializer
 sxml-modifications matchable
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.io
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.process.signal
 chicken.sort
 chicken.string
 chicken.time
 chicken.time.posix
 system-information
)

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))

;;     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/>.
;;

(import defstruct)
(import scsh-process)

(import srfi-18)
(import srfi-19)
(import refdb)

(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 

(import z3)
(import base64)

(let* ((env-str        (with-output-to-string (lambda () (pp (get-environment-variables)))))
       (zipped-env-str (z3:encode-buffer env-str))
       (b64-env-str    (base64-encode zipped-env-str)))
  (print b64-env-str))

;;     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/>.
;;

(import
  chicken.file
  chicken.file.posix
  chicken.io
  chicken.port
  chicken.pretty-print
  chicken.process
  chicken.process-context
  chicken.process-context.posix
  chicken.sort
  chicken.string
  chicken.time
  srfi-4
  system-information

  (srfi 18)
 ;; extras
 chicken.tcp
 s11n

 srfi-1
 ;; posix
 regex regex-case srfi-69
 ;; hostinfo
 md5 message-digest
 ;; directory-utils posix-extras
 matchable
 ;; utils
 chicken.condition
 
 spiffy uri-common intarweb http-client spiffy-request-vars
 )

(declare (unit server))

(declare (uses commonmod))

;;     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/>.


(import defstruct)

;; (import ssax)
;; (import sxml-serializer)
;; (import sxml-modifications)
;; (import regex)
;; (import srfi-69)
;; (import regex-case)
;; (import posix)
;; (import json)
;; (import csv)
(import srfi-18)
(import format)

(require-library ini-file)
(import (prefix ini-file ini:))

(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;; 
(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))

;;     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/>.

(import defstruct)
(import scsh-process)
(import refdb)
(import srfi-18)
(import srfi-19)
(import format)
(import sql-de-lite srfi-1 posix regex regex-case srfi-69)

;(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
(include "sauth-paths.scm")
(include "sauth-common.scm")
(define (toplevel-command . args) #f)
(import readline)

;;
;; GLOBALS
;;
(define *spublish:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish  [action [params ...]]

Version: " megatest-fossil-hash)
)	

(define (toplevel-command . args) #f)

(define (spublish:shell area)
 ; (print area)
  (import readline)

  (let* ((path      '())
	 (prompt    "spublish> ")
	 (args      (argv))
         (usr (current-user-name) )   
         (top-areas (spublish:get-accessable-projects area))
         (close-port     #f)

;;     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/>.
;;

(import defstruct)
(import scsh-process)
(import srfi-18)
(import srfi-19)
(import refdb)
(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
(include "sauth-paths.scm")
(include "sauth-common.scm")

(define (toplevel-command . args) #f)
(import readline)




;;
;; GLOBALS
;;

Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)
)	
;(define (toplevel-command . args) #f)
(define (sretrieve:shell area)
 ; (print area)
  (import readline)
  (let* ((path      '())
	 (prompt    "sretrieve> ")
	 (args      (argv))
         (usr (current-user-name) )   
         (top-areas (sretrieve:get-accessable-projects area))
         (close-port     #f)
         (area-obj  (get-obj-by-code area))

;		   (make-hash-table))))
;      (pop-directory)
;      res)))

(define (toplevel-command . args) #f)
(define (sretrieve:process-action  action . args)
    ; (print action)
 ;  (import readline)
    (case (string->symbol action)
      ((get)
       (if (< (length args) 2)
	   (begin 
	     (sauth:print-error  "Missing arguments; <area> <relative path>" )
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("-m" ) '() args:arg-hash 0))

;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time posix))
  
(require-extension srfi-1 srfi-13 srfi-14 regex)
;; (use  srfi-1 srfi-13 srfi-14 regex)
;; (declare (export parse-cookie-string construct-cookie-string))

;; #>
;; #include <time.h>

;;  PURPOSE.

;; (declare (unit formdat))

(module formdat
    *

(import chicken scheme data-structures extras srfi-13 ports html-filter)


(import regex)
(import srfi-69)

)

;; (declare (unit html-filter))

(module html-filter
    *

(import chicken scheme data-structures extras srfi-13 ports )
(import misc-stml)

(import regex)

;; 
)

;; (declare (unit misc-stml))

(module misc-stml
  *

(import chicken scheme data-structures extras srfi-13 ports posix)
  
(import regex (prefix dbi dbi:))
(import (prefix crypt c:))

)

(import regex posix srfi-69 srfi-1)

(define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm"))

(define (print-page-wrapper lookup page)
  (print "(define (pages:" page " session db shared)")
  (if (hash-table-ref/default lookup (conc page "_ctrl") #f)
      (print "(include \"pages/" page "_ctrl.scm\")"))

;; (declare (unit session))
(module session
    *
  
(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)

(import (prefix dbi dbi:) srfi-69 regex)

(import cookie stmlcommon) ;; (declare (uses cookie))

)

;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(module setup
    *
(import chicken scheme data-structures extras srfi-13 ports posix)

(import session misc-stml)
;; (declare (unit setup))se
;; (declare (uses session))
(import srfi-69 regex)



)

;; This doesn't work yet
;;
(import spiffy cgi-handler)

(spiffy-debug-mode #t)

(spiffy-file-ext-handlers 
 `(("drcdb" . ,(cgi-handler* "/path/to/drcdb"))))

(spiffy-root-path "/path/to/web")

;; Copyright 2007-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;

;; I used this to get a simple interactive sqlite editor on the nokia n800
;; since I couldn't get sqlite3 to install (for reasons I can't remember).

(import sqlite3)

(define args (argv))
(define num-args (length args))

(define dbname #f)
(define cmd    #f)

;; stml is a list of html strings

;; (declare (unit stml))

(module stml2
    *

  (import

    (chicken base)
    (chicken blob)
    (chicken condition)
    (chicken file)
    (chicken format)
    (chicken io)
    (chicken pathname)
    (chicken port)
    (chicken process)
    (chicken process-context posix)
    (chicken process-context)
    (chicken random)
    (chicken string)
    (chicken time posix)
    (chicken time)
    (prefix crypt c:)
    (prefix dbi dbi:)
    cookie
    queues
    regex
    scheme
    srfi-1
    srfi-13
    srfi-69
    typed-records



    )

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
  ;; database
  (dbtype 'pg)
  (dbinit #f)

;; to obscure and indirect database ids use one time keys
;;
;;  (s:get-key 'n 1)     => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;;  (s:key->val "n1882") => 1
;;
;;  first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
  (let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16)))
	(week      (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
    (let loop ((siz 1000)
	       (key (conc key-type week (mkrandstr 100)))
	       (num 0))
      (if (s:session-var-get key) ;; have a collision
	  (loop (cond                 ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
		 ((< num 50)  100)

#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))

#;(define (session:get-nth-char nth)
  (substring session:valid-chars nth  (+ nth 1)))

#;(define (session:get-rand-char)
  (session:get-nth-char (pseudo-random-integer session:num-valid-chars)))

#;(define (session:make-rand-string len)
  (let loop ((res "")
             (n   1))
    (if (> n len) res
        (loop (string-append res (session:get-rand-char))
              (+ n 1)))))

;; maybe replace above make-rand-string with this someday?
;;
#;(define (session:generic-make-rand-string len seed-string)
  (let ((num-chars (string-length seed-string)))
    (let loop ((res "")
	       (n   1))
      (let ((char-num (pseudo-random-integer num-chars)))
	(if (> n len) res
	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
		  (+ n 1)))))))

;; Rely on crypt egg's default settings being secure enough, accept
;; backwards-compatible OpenSSL crypt passwords too.
;;

   ((string? val)  (string->number val))
   ((symbol? val)  (string->number (symbol->string val)))
   (else     #f)))

;; NB// this is *illegal* pgint
(define (s:illegal-pgint val)
  (cond
   ((> val 2147483640.0) 1)   ;;  2147483647
   ((< val -2147483640.0) -1) ;; -2147483648
   (else #f)))

(define (s:any->pgint val)
  (let ((n (s:any->number val)))
    (if n
	(if (s:illegal-pgint n)
	    #f

	(formdat:load-all-port (current-input-port))
	(make-formdat:formdat))))

;; (s:process-cgi-input (caaar dat))
(define (formdat:load-all-port inp)
  (let* ((formdat        (make-formdat:formdat))
	 (debugp         #f))
    ;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
    ;; (write-string (read-string #f inp) #f debugp)  ;; destroys all data!
    (formdat:initialize formdat)
    (let ((alldats (formdat:dat->list inp 10e6 debug-port: #f debugp)))
      
      #;(if debugp (format debugp "formdat : alldats: ~A\n" alldats))

      (let ((firstitem   (car alldats))
	    (multipass #f)) 
	(if (and (not (null? firstitem))
		 (not (null? (car firstitem))))
	    (if (string-match formdat:delim-patt-rex (caar firstitem))
		(set! multipass #t)))

	    ;; 		       (munged (s:process-cgi-input datstr)))
	    ;; 		  (print "datstr: " datstr " munged: " munged)
	    (if (and (not (null? alldats))
		     (not (null? (car alldats)))
		     (not (null? (caar alldats))))
		(formdat:load formdat  (s:process-cgi-input (caaar alldats))))) ;; munged))
	;;		    (format debugp "formdat : name: ~A content: ~A\n" name content)
	#;(if debugp (close-output-port debugp))
	;; (sdat-formdat-set! s:session formdat)
	formdat))))
		
#|
(define inp (open-input-file "tests/example.post.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))

(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))

(define (session:get-nth-char nth)
  (substring session:valid-chars nth  (+ nth 1)))

(define (session:get-rand-char)
  (session:get-nth-char (pseudo-random-integer session:num-valid-chars)))

(define (session:make-rand-string len)
  (let loop ((res "")
             (n   1))
    (if (> n len) res
        (loop (string-append res (session:get-rand-char))
              (+ n 1)))))

;; maybe replace above make-rand-string with this someday?
;;
(define (session:generic-make-rand-string len seed-string)
  (let ((num-chars (string-length seed-string)))
    (let loop ((res "")
	       (n   1))
      (let ((char-num (pseudo-random-integer num-chars)))
	(if (> n len) res
	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
		  (+ n 1)))))))


;;======================================================================
;; P A R A M S

      (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
      (if (eq? dbtype 'sqlite3)
	  ;; The 'auto method will distribute dbs across the disk using hash
	  ;; of user host and user. TODO
	  ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
	  (let ((dbpath (pathname-directory dbfname)))  ;; do a couple sanity checks here to make setting up easier
	    (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
	    (if (not (file-writable? dbpath))
		(session:log self "WARNING: Cannot write to " dbpath)
		(if debugmode (session:log self "INFO: " dbpath " is writeable")))
	    (if (file-exists? dbfname)
		(begin
		  ;; (session:log self "setting dbexists to #t")
		  (set! dbexists #t))))
	  (if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))

;; (declare (run-time-macros))

(module stmlcommon
    *

(import  chicken scheme data-structures extras srfi-13 ports posix)

(import (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)

)

;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (require-extension syntax-case)
;; (declare (run-time-macros))

;; (include "stmlcommon.scm")
(import stml)


(stml:main #f)

(import test md5)


(import (prefix sqlite3 sqlite3:))

(require-library dbi)

;; (declare (uses stml))

(include "requirements.scm")

;;     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/>.

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

(import
 (prefix sqlite3 sqlite3:) srfi-1
 ;; posix
 regex regex-case srfi-69 (srfi 18) 
 ;; posix-extras directory-utils pathname-expand
 typed-records
 ;; format
 ;; call-with-environment-variables

chicken.file
chicken.file.posix
chicken.irregex
chicken.process
chicken.string
chicken.time
chicken.process-context

     )
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))

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

;;======================================================================
;; A hash of hashes that can be kept in sync by sending minial deltas
;;======================================================================

(import format)
(import srfi-1 srfi-69 sqlite3)
(import (prefix sqlite3 sqlite3:))

(declare (unit synchash))
(declare (uses db))
(declare (uses server))
(include "db_records.scm")

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

(import
 sqlite3 srfi-1
 ;; posix
 regex regex-case srfi-69
 ;; dot-locking
 format
 (prefix sqlite3 sqlite3:)
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.process
 chicken.process-context.posix
 chicken.process.signal
 chicken.string
 chicken.time
 srfi-18
 srfi-13
 system-information
 )

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

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

;;
;; Wrapper to enable running Megatest flows under teamcity
;;
;;  1. Run the megatest process and pass it all the needed parameters
;;  2. Every five seconds check for state/status changes and print the info
;;

(import
 srfi-1
 ;; posix
 srfi-69 srfi-18 regex defstruct)

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

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

 (srfi 18)
 ;; extras tcp)

 sqlite3 srfi-1
 ;; posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64

 (prefix sqlite3 sqlite3:)
 (prefix base64 base64:)
 chicken.file.posix
 chicken.io
 chicken.port
 chicken.pretty-print
 chicken.sort
 chicken.string
 chicken.time
 chicken.condition
 srfi-69
)

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

(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
(declare (uses stml2))

(import
 sqlite3 srfi-1
 ;; posix regex regex-case srfi-69
 ;; dot-locking
 ;; tcp directory-utils
 (prefix sqlite3 sqlite3:)
 stml2
 chicken.condition
 chicken.file
 chicken.file.posix
 chicken.format
 chicken.io
 chicken.pathname
 chicken.port
 chicken.pretty-print
 chicken.process
 chicken.process-context
 chicken.process-context.posix
 chicken.sort
 chicken.string
 chicken.time
 srfi-13
 srfi-18
 srfi-69
 system-information
 regex
 
 )

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

;;     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/>.
;;
;;======================================================================

(import format)
(require-library iup)
(import (prefix iup iup:))
(import canvas-draw)

(import
 sqlite3 srfi-1
 ;; posix
 regex regex-case srfi-69
 (prefix sqlite3 sqlite3:)
 chicken.port
 chicken.pretty-print
 chicken.string
 chicken.time
 srfi-13
 chicken.bitwise
 srfi-69
 )

(declare (unit tree))
(declare (uses margs))
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))

#!/bin/bash

MODNAME=$1

mkdir -p tmpmods

echo "(module $MODNAME
   *

(import 
   scheme
   chicken.base)

(include \"$MODNAME.scm\")
)" > tmpmods/$MODNAME.scm

;;     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/>.
;;
(import canvas-draw iup foof-loop)
(import canvas-draw-iup)

(load "vg.scm")

(define numtorun 1000)
;; (if (> (length (argv)) 1)
;; 		     (string->number (cadr (argv)))
;; 		     1000))

 (import trace)
 ;; (trace 
 ;;  ;; vg:draw-rect
 ;;  ;; vg:grow-rect
 ;;  vg:get-extents-for-objs
 ;;  vg:components-get-extents
 ;;  vg:instances-get-extents
 ;;  vg:get-extents-for-two-rects

;;     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/>.

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

(import typed-records srfi-1)

(declare (unit vg))
(import canvas-draw iup)
(import
 canvas-draw-iup
 chicken.bitwise
 srfi-69
 chicken.string
 )

(include "vg_records.scm")

;; ;; structs
;; ;;
;; (defstruct vg:lib     comps)
;; (defstruct vg:comp    objs name file)

;;     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/>.
;;

(import simple-exceptions)
(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
(define (make-vg:lib #!key 
              (comps #f)
         )
    (vector 'vg:lib comps))

(define-inline (vg:lib-comps       vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref  vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))

(define-inline (vg:lib-comps-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
;; Generated using make-vector-record -safe vg comp objs name file

(import simple-exceptions)
(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
(define (make-vg:comp #!key 
              (objs #f)
              (name #f)
              (file #f)
         )
    (vector 'vg:comp objs name file))

(define-inline (vg:comp-objs       vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref  vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
(define-inline (vg:comp-name       vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref  vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
(define-inline (vg:comp-file       vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref  vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))

(define-inline (vg:comp-objs-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
(define-inline (vg:comp-name-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
(define-inline (vg:comp-file-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc

(import simple-exceptions)
(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
(define (make-vg:obj #!key 
              (type #f)
              (pts #f)
              (fill-color #f)
              (text #f)

(define-inline (vg:obj-angle-set!       vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
(define-inline (vg:obj-font-set!        vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
(define-inline (vg:obj-attrib-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
(define-inline (vg:obj-extents-set!     vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
(define-inline (vg:obj-proc-set!        vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache

(import simple-exceptions)
(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
(define (make-vg:inst #!key 
              (libname #f)
              (compname #f)
              (theta #f)
              (xoff #f)

(define-inline (vg:inst-scaley-set!     vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
(define-inline (vg:inst-mirrx-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
(define-inline (vg:inst-mirry-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
(define-inline (vg:inst-call-back-set!  vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
(define-inline (vg:inst-cache-set!      vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache

(import simple-exceptions)
(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
(define (make-vg:drawing #!key 
              (libs #f)
              (insts #f)
              (scalex #f)
              (scaley #f)