#!c:\perl\bin\perl.exe -w
#=============================================================================
#   @(#)$Id$
#-----------------------------------------------------------------------------
#   Test-driven development script for Scheme functions.  See course web
#   page for details on test case format and usage.
#
#   usage summary:
#       tddscm.pl <scheme-src-file-name> <scheme-fn> <test-case-file-name> 
#=============================================================================

use strict;
use English;

if ( $#ARGV != 2 )
{
    die "usage:\n" .
	"    tddscm.pl <src-file-name> <scheme-fn> <test-case-file-name>\n";
}

#=============================================================================
# User-configurable paths: You may need to edit these definitions to
# reflect where scheme is installed on your system.  Note that spaces
# shouldn't be used in these path names, since they'll confuse system()
# unless they are properly escaped.
#=============================================================================
my $scheme_home = "c:/Progra~1/MIT/Scheme/";
my $scheme      = $scheme_home . "bin/scheme";
my $scheme_lib  = "-library ${scheme_home}lib";


#=============================================================================
# Bring command line args into local variables for easy reference
#=============================================================================
my $student_src   = $ARGV[0];	# source file name 
my $student_exec  = $ARGV[1];	# source file name 
my $student_tests = $ARGV[2];	# test case file
                                # (includes expected output)


#=============================================================================
# In addition, some local definitions within this script
#=============================================================================
my $version         = "1.0";
my @labels          = ();	# User-provided test case names
my @test_cases	    = ();	# test case input
my @expected_output = ();	# corresponding expected output
my @case_nos        = ();       # test case number for each output line
my $temp_input      = "$PID.in";  # Name for temp test input file
my $temp_output     = "$PID.out"; # Name for temp test output file
my $delete_temps    = 1;        # Change to 0 to preserve temp files


#=============================================================================
# A subroutine for normalizing output lines before comparing them
#=============================================================================
sub normalize
{
    my $line = shift;
    $line =~ s/^\s+//o;		# Trim leading space
    $line =~ s/\s+$//o;		# Trim trailing space
    $line =~ s/\s+/ /go;	# Convert multi-space sequences to one space
    $line =~ s/\(\s+/(/go;	# Eliminate spaces inside parentheses
    $line =~ s/\)\s+/)/go;	# Eliminate spaces inside parentheses
    $line =~ tr/A-Z/a-z/;	# Convert to lower case
    return $line;
}


#=============================================================================
# Phase I: Parse and split the test case input file
#=============================================================================

open ( CASES, $student_tests ) ||
    die "Cannot open '$student_tests': $!";

my $scanning_input = 0;
my $case = -1;
while ( <CASES> )
{
    # skip comment lines
    next if ( m,^//(?!--|==),o );

    if ( m,^//==,o )
    {
	if ( $scanning_input )
        {
	    print "$student_tests: ", $INPUT_LINE_NUMBER - 1,
	          ": improperly formatted test case.\n";
        }
	my $label = $_;
	chomp $label;
	$label =~ s,^//==[-=\s]*,,o;
	$label =~ s,[-=\s]*$,,o;
	# if ( $label eq "" ) { $label = "(no label)"; }
	push( @labels, $label );
	push( @test_cases, "" );
	$case++;
	$scanning_input = 1;
    }
    elsif ( m,^//--,o )
    {
	if ( ! $scanning_input )
	{
	    print "$student_tests: ", $INPUT_LINE_NUMBER,
	        ": improperly formatted test case; cannot proceed.\n";
	}
	$scanning_input = 0;
    }
    else
    {
	if ( $scanning_input )
	{
	    # Then this is an input line
	    if ( $#test_cases < 0 )
	    {
	        print "$student_tests: ", $INPUT_LINE_NUMBER,
	              ": improperly formatted test case.\n";
	    }
	    else
	    {
		$test_cases[$#test_cases] .= $_;
		if ( $labels[$#labels] eq "" )
		{
		    # Use first line of input for case label
		    chomp;
		    $labels[$#labels] = $_;
		}
	    }
	}
	else
	{
	    if ( $#labels < 0 )
	    {
		print "$student_tests: ", $INPUT_LINE_NUMBER,
	              ": improperly formatted test case.\n";
	    }
	    push( @expected_output, normalize( $_ ) );
	    push( @case_nos, $case );
	}
    }
}

## For debugging purposes:
# print "labels => '", join( "', '", @labels ), "'\n";
# print "inputs => '", join( "', '", @test_cases ), "'\n";
# print "outputs => '", join( "', '", @expected_output ), "'\n";
# print "case_nos => '", join( "', '", @case_nos ), "'\n";


#=============================================================================
# Phase II: Execute the program
#=============================================================================

print "\ntddscm.pl v$version   (c) 2003 Virginia Tech. All rights reserved.\n";
print "Testing $student_src/$student_exec using $student_tests\n";
open( INFILE, "> $temp_input" ) ||
    die "Cannot open '$temp_input': $!";
print INFILE<<EOF;
;; First, define a testing function that will trap and print out
;; any run-time errors that arise in the user's code:
(define (test-case arglist)
  (let ( (result (ignore-errors (lambda () (apply $student_exec arglist)))) )
    (cond
     ((condition? result) (write-string "Runtime Error: ")
			  (write-string (condition/report-string result)))
     (else (write result))
    )
  )
  (newline)
)

;; Now, redirect output to the desired file:
(ignore-errors (lambda ()
(with-output-to-file "$temp_output" (lambda ()

;; Now load the user's file, trapping any load-time errors:
(let ( (file-load-result (ignore-errors (lambda ()
					  (load "$student_src")
					  ))) )
  (cond
   ;; Make sure that everything is OK to run tests
   ((condition? file-load-result)
        (write-string "File Load Error: ")
	(write-string (condition/report-string file-load-result)))
   ((not (environment-bound? (the-environment) '$student_exec))
        (write-string "Error: ")
	(write-string "$student_exec is not defined."))
   ((not (procedure? $student_exec))
        (write-string "Error: ")
	(write-string "$student_exec is not a procedure."))
   (else
    ;; Now, run each test in turn
EOF
# to counteract the ' in the output above, for emacs
foreach my $case ( @test_cases )
{
    # need to ensure $case has balanced parentheses
    my $lparens = ( () = $case =~ /\(/g );
    my $rparens = ( () = $case =~ /\)/g );
    if ( $lparens > $rparens )
    {
	print "$student_tests: unbalanced parentheses in test case input:\n",
	      $case;
	$case .= ')' x ( $lparens - $rparens );
    }
    elsif ( $rparens > $lparens )
    {
	print "$student_tests: unbalanced parentheses in test case input:\n",
	      $case;
	$case = ( '(' x ( $rparens - $lparens ) ) . $case;
    }
    
    print INFILE "    (test-case '($case))\n";
}
print INFILE<<EOF;
    )
   )
)

))))

;; Exit from Scheme when done
(%exit 0)
EOF
close( INFILE );
system( "$scheme $scheme_lib -load $temp_input" );
if ( $delete_temps )
{
    unlink( "$temp_input" );
}


#=============================================================================
# Phase III: Compare the output to test case expectations
#=============================================================================

my $line        = 0;    # next line in @expected_output to match
my $last_failed = -1;	# index of last failed case
my $failures    = 0;    # count of failures
my $errs        = 0;    # Number of runtime errors, which is 0 or 1 since
                        # such an error crashes the program

open( STUDENT, "$temp_output" ) ||
    die "Cannot open temporary output file '$temp_output': $!";

while ( <STUDENT> )
{
    if ( $line > $#expected_output )
    {
	# If the expected output has run out, just add up the remaining
	# lines as errors or crashes.
	while ( defined $_ )
	{
	    if ( m/^(runtime |file load |)error/io )
	    {
		$errs++;
	    }
	    else
	    {
		$failures++;
	    }
	    $_ = <STUDENT>;
	}
	last;
    }

    # If the line does not match the expected output
    if ( normalize( $_ ) ne $expected_output[$line] )
    {
	if ( $line % 78 == 0 )
	{
	    print "\n";
        }
	my $this_fail = $case_nos[$line];
	print "F";
	if ( $this_fail != $last_failed )
	{
	    print "\ncase ", $this_fail + 1,
	          " FAILED: $labels[$this_fail]\n";
	    $failures++;
	    # print "expected: '$expected_output[$line]'\n";
	    # print "got:      '", normalize( $_ ), "'\n";
	}
	$last_failed = $this_fail;
    }
    else
    {
	if ( $line % 78 == 0 )
	{
	    print "\n";
        }
	print ".";
    }
    $line++;
}

close( STUDENT );

if ( $line <= $#expected_output )
{
    $failures += $#expected_output - $line + 1;
}

if ( $failures + $errs == 0  &&  $delete_temps )
{
    unlink( $temp_output );
}

my $num_cases = $#labels + 1;
print "\n\nTests Run: $num_cases, Errors: $errs, Failures: $failures (",
    sprintf( "%.1f", ($num_cases - $failures - $errs)/$num_cases*100 ),
    "%)\n";
if ( $failures + $errs > 0 )
{
    print "Output has been saved in $temp_output.\n";
}

#=============================================================================
# Exit Script
#=============================================================================
exit(0);