Megatest

PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
           server.scm configf.scm db.scm keys.scm margs.scm		\
           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           tdb.scm mt.scm	\
           ezsteps.scm rmt.scm api.scm		\
           subrun.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            tcp-transportmod.scm rmtmod.scm portlogger.scm

	common.o \
	configf.o \
	db.o \
	env.o \
	items.o \
	keys.o \
	launch.o \

	margs.o \
	mt.o \
	ods.o \
	process.o \
	rmt.o \
	runconfig.o \
	runs.o \

	if  csi -ne '(import mysql-client)'&> /dev/null;then \
           echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(import postgresql)'&> /dev/null;then \
	   echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
#	csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o sync-hash.o tasks.o tdb.o tests.o tree.o

unitdeps.dot : *scm ./utils/plot-uses Makefile
	./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot

unitdeps.pdf : unitdeps.dot
	dot unitdeps.dot -Tpdf -o unitdeps.pdf

./utils/plot-uses : utils/plot-uses.scm
	csc utils/plot-uses.scm

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make








targets:
	@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'


unit :
	cd tests;make unit

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

(declare (uses db))
(declare (uses debugprint))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))

(declare (uses tcp-transportmod))

(import dbmod)
(import dbfile)
(import debugprint)

(import tcp-transportmod)

(use srfi-69
     posix
     matchable
     s11n)

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


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



)

;;  testsuite and area utilites
;;
;;======================================================================

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

;; http - use the old http + in /tmp db
;; tcp  - use tcp transport with inmem db
;; nfs  - use direct to disk access (read-only)
;;
(define rmt:transport-mode (make-parameter 'tcp))

(define (get-full-version)
  (conc megatest-version "-" megatest-fossil-hash))

(define (version-signature)
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

(define *common:denoise*    (make-hash-table)) ;; for low noise printing

	commonmod
	debugprint
;; 	dbmemmod
	dbfile
	dbmod
	tcp-transportmod)






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

;; generate entries for ~/.megatestrc with the following
;;
;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u

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

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

(declare (unit tests))

(declare (uses db))
(declare (uses tdb))
(declare (uses debugprint))
(declare (uses common))
(declare (uses commonmod))

(declare (uses items))
(declare (uses runconfig))

(declare (uses server))

(declare (uses mtargs))
(declare (uses rmtmod))

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

#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq

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

;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;;        dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan

(module plot-uses
	*

(import scheme chicken)

(use regex srfi-69 srfi-13)
(use matchable data-structures ports extras)

(define unituses-rx (regexp "^\\(declare \\((unit|uses) ([^\\(\\)]+)\\).*"))

(define (print-err . data)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print data))))

(define (process-file ignores fname)
  (with-input-from-file fname
    (lambda ()
      (let loop ((modname "DUMMYMOD"))
	(let* ((inl (read-line)))
	  (if (eof-object? inl)
	      #t
	      (match (string-search unituses-rx inl)
 	         ((_ dtype unitname)
		  (if (equal? dtype "unit")
		      (loop unitname)
		      (begin
			(if (equal? dtype "uses")
			    (if (not (or (member modname '("DUMMYMOD"))
					 (member modname ignores)
					 (member unitname ignores)))
				(print "  \""unitname"\" -> \""modname"\";"))
			    (print-err "ERROR: bad declare line \""inl"\""))
			(loop modname))))
		 (else
		  (loop modname)))))))))

(define (main)
  (match (command-line-arguments)
    (("todot" ignoreunits . files)
     (let* ((ignores (string-split ignoreunits ",")))
       (print-err "Making graph for files: " (string-intersperse files ", "))
       (print "digraph uses_unit {")
       (for-each
	(lambda (fname)
	  (print "// Filename: "fname)
	  (process-file ignores fname))
	files)
       (print "}")))
    (else
     (print-err "Usage: plot-uses u1,u2... file1.scm ...")
     (print-err "    where u1,u2... are units to ignore and file1.scm... are the files to process."))))

(main)

)
;; 
;; ;; Gather the usages
;; (print "digraph G {")
;; (define curr-cluster-num 0)
;; (define function-calls '())
;; 
;; (for-each
;;  (lambda (fname)
;;    (let ((last-func #f))
;;      (print-err "Processing file " fname)
;;      (print "subgraph cluster_" curr-cluster-num " {")
;;      (set! curr-cluster-num (+ curr-cluster-num 1))
;;      (with-input-from-file fname
;;        (lambda ()
;; 	 (with-output-to-port (current-error-port)
;; 	   (lambda ()
;; 	     (print "Analyzing file " fname)))
;; 	 (print "label=\"" fname "\";")
;; 	 (let loop ((inl    (read-line))
;; 		    (fnname "toplevel")
;; 		    (allcalls '()))
;; 	   (if (eof-object? inl)
;; 	       (begin
;; 		 (set! function-calls (cons (list fnname allcalls) function-calls))
;; 		 (for-each 
;; 		  (lambda (call-name)
;; 		    (hash-table-set! breadcrumbs call-name #t))
;; 		  allcalls)
;; 		 (print-err "function: " fnname " allcalls: " allcalls))
;; 	       (let ((match (string-match defn-rx inl)))
;; 		 (if match
;; 		     (let ((func-name (cadr match)))
;; 		       (if last-func
;; 			   (print "\"" func-name "\" -> \"" last-func "\";")
;; 			   (print "\"" func-name "\";"))
;; 		       (set! last-func func-name)
;; 		       (hash-table-set! breadcrumbs func-name #t)
;; 		       (loop (read-line)
;; 			     func-name
;; 			     allcalls))
;; 		     (let ((calls (look-for-all-calls inl fnname)))
;; 		       (loop (read-line) fnname (append allcalls calls)))))))))
;;      (print "}")))
;;  targs)
;; 
;; (print-err "breadcrumbs: " (hash-table-keys breadcrumbs))
;; (print-err "function-calls: " function-calls)
;; 
;; (for-each 
;;  (lambda (function-call)
;;    (print-err "function-call: " function-call)
;;    (let ((fnname (car function-call))
;; 	 (calls  (cadr function-call)))
;;      (for-each
;;       (lambda (callname)
;; 	(print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ")
;; 	       "\"" fnname "\" -> \"" callname "\";"))
;;       calls)))
;;  function-calls)
;; 
;; (print "}")
;; 
;; (exit)
;;