Megatest

SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = launch.scm runconfig.scm	\
           server.scm configf.scm keys.scm		\
           process.scm runs.scm \
           mt.scm	\
           ezsteps.scm api.scm		\
           subrun.scm archive.scm env.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 apimod.scm \
	    configfmod.scm processmod.scm servermod.scm megatestmod.scm \
	    stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \
            pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \
            subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \
            ezstepsmod.scm mtbody.scm envmod.scm genexample.scm mutils.scm \
            diff-report.scm tdb.scm

transport-mode.scm : transport-mode.scm.template
	cp transport-mode.scm.template transport-mode.scm

dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

mtest : transport-mode.scm
dboard : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here

mofiles/mtbody.o     : mofiles/launchmod.o readline-fix.scm mofiles/envmod.o mofiles/genexample.o mofiles/mutils.o mofiles/diff-report.o mofiles/tdb.o
process.o            : mofiles/processmod.o
mofiles/configfmod.o : mofiles/processmod.o
mofiles/processmod.o : mofiles/commonmod.o
mofiles/servermod.o  : mofiles/commonmod.o
mofiles/rmtmod.o     : mofiles/mtmod.o mofiles/apimod.o
mofiles/dbmod.o      : mofiles/mtmod.o
# mofiles/mtmod.o      : mofiles/tcp-transportmod.o

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

;; (include "common.scm")
;; (include "megatest-version.scm")




;; (declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))

(declare (uses diff-report))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses genexample))
(declare (uses mtbody))

(import csi)
;; fake out readline usage of toplevel-command
(set! toplevel-command (lambda (a b) #f))

(import mtbody)

(main)

(declare (uses genexample))
(declare (uses rmtmod))
(declare (uses archivemod))
(declare (uses mutils))
(declare (uses odsmod))
(declare (uses testsmod))
(declare (uses diff-report))
(declare (uses tdb))

(use srfi-69)
(import csi)

(module mtbody
	*
	
(import scheme)
(cond-expand
 (chicken-4

	  files
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  posix
	  posix-extras
	  ;;	  readline
	  regex
	  regex-case
	  sparse-vectors
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records

	  typed-records
	  system-information

	  debugprint
  )))

;; imports common to chk5 and ck4
(import srfi-13
	csi)

(import (prefix mtargs args:)
        archivemod
	debugprint
	dbmod
	commonmod
	processmod

	envmod
	apimod
	genexample
	mutils
	odsmod
	testsmod
	diff-report
	tdb
        )

(include "common_records.scm")

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

;; (set! toplevel-command toplevel-command)

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

(import (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
(import
 ;; readline
 apropos json http-client directory-utils typed-records)
(import http-client srfi-18 extras format tcp-server tcp)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(require-library mutils)

       (lambda (target runname keys keyvals)
	 (runs:handle-locking 
	  target
	  keys
	  (or (args:get-arg "-runname")(args:get-arg ":runname") )
	  (args:get-arg "-lock")
	  (args:get-arg "-unlock")
	  (current-user-name)))))

  ;;======================================================================
  ;; Get paths to tests
  ;;======================================================================
  ;; Get test paths matching target, runname, and testpatt
  (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
      ;; if we are in a test use the MT_CMDINFO data

	;;	    (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
	;;	    (exit 1)))

	(let ((dbstructs (db:setup)))
          (common:cleanup-db dbstructs))
	(set! *didsomething* #t)))

  #;(if (args:get-arg "-mark-incompletes")
      (begin
	(if (not (launch:setup))
	    (begin
	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
	      (exit 1)))
	(open-run-close db:find-and-mark-incomplete #f)
	(set! *didsomething* #t)))

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

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


  (when (args:get-arg "-diff-rep")
    (when (and
           (not (args:get-arg "-diff-html"))
           (not (args:get-arg "-diff-email")))
      (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
      (set! *didsomething* 1)

	      ;; #!/bin/bash
	      ;;
	      ;; export MT_RUNSCRIPT=yes
	      ;; megatest << EOF
	      ;; (print "Hello world")
	      ;; (exit)
	      ;; EOF
    
	      (repl))
	     (else
	      (begin
		(define toplevel-command (lambda (a b)(print a " "b)))
		(set! *db* dbstructs)
		(import extras) ;; might not be needed
		;; (import csi)
		;; (import readline)
		(import apropos)
		(import dbfile)
		
		;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...

		(if *use-new-readline*
		    (begin
		      #;(install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
		      #;(current-input-port (make-readline-port "megatest> ")))
		    #;(begin
		      (gnu-history-install-file-manager
		       (string-append
			(or (get-environment-variable "HOME") ".") "/.megatest_history"))
		      (current-input-port (make-gnu-readline-port "megatest> "))))
		(if (args:get-arg "-repl")
		    (repl)

(declare (uses mtmod))
(declare (uses tcp-transportmod))
(declare (uses apimod))
(declare (uses servermod))

(module rmtmod
	(
	 rmt:test-data-rollup
	 rmt:import-sexpr
	 rmt:read-test-data-varpatt
	 rmt:get-run-status
	 rmt:set-run-status

	 rmtmod:send-receive
	 rmt:send-receive

(define (rmt:get-test-state-status-by-id run-id test-id)
  (rmtmod:send-receive 'get-test-state-status-by-id run-id (list run-id test-id)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmtmod:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))









;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmtmod:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))

(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
  (assert (number? run-id) "FATAL: Run id required.")

>;;======================================================================
;; Copyright 2006-2013, 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

(declare (uses debugprint))
;; (declare (uses common))
(declare (uses keys))
(declare (uses mt))
(declare (uses commonmod))
(declare (uses mtargs))
(declare (uses rmtmod))

(module tdb
	*

(import scheme
	chicken
	data-structures
	)

(require-extension (srfi 18) extras tcp)

(import srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5
	message-digest base64)

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

(import commonmod
	debugprint
	rmtmod
	(prefix mtargs args:))

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

;;======================================================================
;;
;; T E S T   D A T A B A S E S
;;
;;======================================================================

;;======================================================================
;; T E S T   S P E C I F I C   D B 
;;======================================================================

;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (let* ((test-path (if (string? work-area)
;; 			work-area
;; 			(rmt:test-get-rundir-from-test-id run-id test-id))))
;;     (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;;     (open-test-db test-path)))


;; =not-used= ;; Create the sqlite db for the individual test(s)
;; =not-used= ;;
;; =not-used= ;; Moved these tables into <runid>.db
;; =not-used= ;; THIS CODE TO BE REMOVED
;; =not-used= ;;
;; =not-used= (define (open-test-db work-area) 

          (rmt:csv->test-data run-id test-id lin)
          ;;)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status too 
  (rmt:test-data-rollup run-id test-id #f))

;; ;; NOTE: Run this local with #f for db !!!
;; (define (tdb:load-logpro-data run-id test-id)
;;   (let loop ((lin (read-line)))
;;     (if (not (eof-object? lin))
;; 	(begin
;; 	  (debug:print 4 *default-log-port* lin)
;;           ;;(when lin  ;; this when blocked stack dump caused by .dat file from logpro being 0-byte.  fixed by upgrading logpro
;;           (rmt:csv->test-data run-id test-id lin)
;;           ;;)
;; 	  (loop (read-line)))))
;;   ;; roll up the current results.
;;   ;; FIXME: Add the status too 
;;   (rmt:test-data-rollup run-id test-id #f))

;;======================================================================
;; S T E P S 
;;======================================================================

(define (tdb:step-get-time-as-string vec)
  (seconds->time-string (tdb:step-get-event_time vec)))

			 (if (eq? time-a time-b)
			     (string<? (conc (vector-ref a 2))
				       (conc (vector-ref b 2)))
			     #f))
		     (string<? (conc time-a)(conc time-b))))))))

;; 
;; (define (tdb:remote-update-testdat-meta-info run-id test-id work-area
;; 					     cpuload diskfree minutes)
;;   (let ((tdb         (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
;;     (if (sqlite3:database? tdb)
;; 	(begin
;; 	  (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
;; 			   cpuload diskfree minutes)
;; 	  (sqlite3:finalize! tdb))
;; 	(debug:print 2 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant"))))
;;     
)