Megatest

;; Copyright 2007-2010, 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 margs))
;; (declare (uses common))

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

(define (args:any? . args)
  (not (null? (filter (lambda (x) x)
		      (map args:get-arg args)))))

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

(define (args:usage . args)
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))

 ;; one-of args defined
(define (args:any-defined? . param)
  (let ((res #f))
    (for-each 
     (lambda (arg)
       (if (args:get-arg arg)(set! res #t)))
     param)
    res))

;; args: 
(define (args:get-args args params switches arg-hash num-needed)
  (let* ((numargs (length args))
	 (adj-num-needed (if num-needed (+ num-needed 2) #f)))
    (if (< numargs (if adj-num-needed adj-num-needed 2))
	(if (>= num-needed 1)
	    (args:usage "No arguments provided")
	    '())
	(let loop ((arg (cadr args))
		   (tail (cddr args))
		   (remargs '()))
	  (cond 
	   ((member arg params) ;; args with params
	    (if (< (length tail) 1)
		(args:usage "param given without argument " arg)
		(let ((val     (car tail))
		      (newtail (cdr tail)))
		  (hash-table-set! arg-hash arg val)
		  (if (null? newtail) remargs
		      (loop (car newtail)(cdr newtail) remargs)))))
	   ((member arg switches)         ;; args with no params (i.e. switches)
	    (hash-table-set! arg-hash arg #t)
	    (if (null? tail) remargs
		(loop (car tail)(cdr tail) remargs)))
	   (else
	    (if (null? tail)(append remargs (list arg)) ;; return the non-used args
		(loop (car tail)(cdr tail)(append remargs (list arg))))))))
    ))

(define (args:print-args remargs arg-hash)
  (print "ARGS: " remargs)
  (for-each (lambda (arg)
	      (print "   " arg "   " (hash-table-ref/default arg-hash arg #f)))
	    (hash-table-keys arg-hash)))

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

;;  megatest.scm mofiles/autoload.o mofiles/dbi.o mofiles/ducttape-lib.o
;;  mofiles/pkts.o mofiles/stml2.o mofiles/cookie.o mofiles/mutils.o
;;  mofiles/mtargs.o

;; (include "mutils/mutils.scm")
;; (include "autoload/autoload.scm")
;; (include "dbi/dbi.scm")
;; (include "stml2/cookie.scm")
;; (include "stml2/stml2.scm")
;; (include "pkts/pkts.scm")
;; (include "csv-xml/csv-xml.scm")
;; (include "ducttape/ducttape-lib.scm")
;; (include "hostinfo/hostinfo.scm")
;; (include "adjutant.scm")

(declare (uses autoload))
(declare (uses dbi))
(declare (uses pkts))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses csv-xml))
(declare (uses hostinfo))

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

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

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

(include "common.scm")
;; (include "margs.scm")
(include "db.scm")
(include "server.scm")
(include "tests.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "env.scm")
(include "diff-report.scm")

     					    (printf "Sending signal/term to ~A\n" pid)
     					    (process-signal pid signal/term))))))
     		       (process:children #f))
     		      (original-exit exit-code)))))
     
     ;; for some switches always print the command to stderr
     ;;
     (if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
     (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
         (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
     
     ;; some switches imply homehost. Exit here if not on homehost
     ;;
     (let ((homehost-required  (list "-cleanup-db" "-server")))
       (if (apply args:any? homehost-required)
       (if (apply args:any-defined? homehost-required)
           (if (not (common:on-homehost?))
     	  (for-each
     	   (lambda (switch)
     	     (if (args:get-arg switch)
     		 (begin
     		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
     				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")

     				     (display (conc "target: " targetstr " "))
     				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
     			       runs-spec)
     			      (newline)))))
     		       
     		     (for-each 
     		      (lambda (test)
     		      	(common:debug-handle-exceptions #f
     		      	(handle-exceptions
     			 exn
     			 (begin
     			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
     			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
     			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     			   (print-call-chain (current-error-port)))
     			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))

              ((1)(exit 1))
              ((2)(exit 2))
              (else (exit 3)))))
     )

)

;; (main)
(print "Got here")
(main)