#
#  Copyright (c) 1997-2002 The Protein Laboratory, University of Copenhagen
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
#  $Id$
#
package main;
use vars qw( @ISA $noX11 $w $dong);
use strict;
# startup
use Prima::Config;
use Prima::noX11;
use Prima;

# testing if is running over a dumb terminal
$noX11 = 1 if defined Prima::XOpenDisplay();

# should be ok now
my $verbose = 0;
my $tie     = 1;
my $testing = 0;
my @results = ();
my @extras  = ();
my @extraTestNames  = ();
my $ok_count;
my $testsRan = 0;
my ( $skipped, $passed, $failed) = (0,0,0);
my ( $eskipped, $epassed, $efailed) = (0,0,0);
my @filters;
#
my $tick;

init();
run();
exit;

package ExTiedStdOut;

sub TIEHANDLE
{
	my $class = shift;
	my $isError = shift;
	bless \$isError, $class;
}

sub analyze
{
	unless ( $testing) {
		print STDERR $_[0];
		return;
	}
	if ( scalar @results == 0 && $_[0] =~ /\d+\s*\.\.\s*(\d+)\s*(.*)/) {
		if ( $1 > 0) {
			@results = ((0) x ( $1));
			@extraTestNames = ();
			my @a = split( ',', $2);
			my $i;
			for ( $i = 0; $i < @a; $i++) { $extraTestNames[$i] = $a[$i]; }
		} else {
			push( @extras, $_[0]);
		}
	} else {
		if ( $_[0] =~ /(not\s+)?ok(.*)\b/) {
			my $notOK = defined $1;
			my $id;
			my $ex = $2;
			if ( $_[0] =~ /ok\s+(\d+)/) {
				$id = $1;
			} else {
				$id = $ok_count;
			}
			if ( defined $ex) {
				$ex = ( $ex =~ /\s+\#\s+skip/i) ? 1 : undef;
			}
			if (( $id > 0 && $id <= scalar @results) || ( scalar @results == ( $id - 1))) {
				$results[ $id - 1] = $ex ? -1 : ( $notOK ? 0 : 1);
			} else {
				push( @extras, "! test $id of ".@results." run");
			}
		} else {
			push( @extras, $_[0]);
		}
	}
}

sub PRINT {
	my $r = shift;
	$$r++;
	analyze( join( '', @_));
}

sub PRINTF {
	shift;
	my $fmt = shift;
	analyze( sprintf($fmt, @_));
}

package main;

sub __end_wait
{
	$tick = 1;
}

sub __wait
{
	return 0 if $noX11;
	$tick = 0;
	my $t = Prima::Timer-> create( timeout => 500, 
		onTick => sub { $tick = 1 });
	$dong = 0;
	$t-> start;
	while ( 1) {
		last if $dong || $tick;
		$::application-> yield;
	}
	$t-> destroy;
	return $dong;
}

sub __dong
{
	$dong = 1;
}

sub ok
{
	print $_[0] ? "ok $ok_count\n" : "not ok $ok_count\n";
	$ok_count++;
}

sub skip
{
	print "ok # skip\n";
	$ok_count++;
}

sub runfile
{
	my $d = $_[0];
	$d =~ s/.t$//;
	my $content;
	{
		open F, $_[0] or die "Error: cannot open $_[0]:$!\n";
		local $/;
		$content = <F>;
		close F;
	}
	if ( $noX11) {
		# check if can run
		if ( $content =~ /Widget|Window|Timer|Drawable|DeviceBitmap|pplication|begin_paint|Menu|Popup|__wait/) {
			print "Testing $d...skipped\n" if $verbose;
			$eskipped++;
			return;
		}
	}
	print "Testing $d...";
	$ok_count = 1;
	$testing = 1;
	@results = ();
	@extras  = ();
	my $c = eval { eval $content; };
	$testing = 0;
	if ( $@) {
		print "test error: $@\n"
	} else {
		my $res = 3;
		for ( @results) {
			if ( $_ < 0) { $skipped++} elsif ( $_ > 0) { $passed++} else { $failed++};   
			next if $_ < 0;
			$res &= $_ ? 1 : 0;
		}   
		if ( $res == 3) { $eskipped++} elsif ( $res) { $epassed++} else { $efailed++};
		
		if ( $verbose) {
			my $i = 0;
			print "\n";
			for ( @results) {
				my $exName = defined $extraTestNames[ $i] ? "  ($extraTestNames[$i])" : '';
				my $j = $i + $testsRan + 1;
				print "test $j:".(( $_ < 0 ) ? "skipped" : (( $_ > 0) ? "passed" : "failed")).$exName."\n";
				$i++;
			}
			$testsRan += $i;
			print "$_\n" for @extras;
		} else {
			my $res = 1;
			my ( $nf, $nr) = ( 0, scalar @results);
			for ( @results) {
				next if $_ < 0;
				$res &= $_;
				$nf++ unless $_;
			}
			$testsRan++;
			print (( $res ? "passed" : "failed ($nf/$nr)")."\n");
		}
	}
}

sub rundir
{
	my $dir = $_[0];
	opendir( FDIR, $dir);
	my @f = readdir( FDIR);
	closedir FDIR;
	my @files = ();
	my @index = ();

	for ( @f) {
		next if ( $_ eq ".") || ( $_ eq "..");
		if ( $_ eq 'order') {
			if ( open F, "$dir/$_") {
				@index = <F>;
				close F;
				chomp for @index;
			}
			next;
		}
		push @files, $_;
	}

	my %h = map { $_ => 1 } @files;
	@f = ();
	for ( @index) {
		next unless length( $_);
		if ( exists $h{$_}) {
			push( @f, $_);
			$h{$_} = 0;
		}
	}

	for ( keys %h) {
		push( @f, $_) if $h{$_};
	}

	for ( @f)
	{
		my $ff = "$dir/$_";
		if ( -d $ff) {
			rundir( $ff);
		} elsif ( -f $ff) {
			next unless $_ =~ /\.t$/;
			if ( scalar @filters) {
				my $match;
				for ( @filters) {
					$match = 1, last if $ff =~ /$_$/;
				}
				next unless $match;
			}
			runfile( $ff);
		}
	}

}

sub init
{
	unless ($^O !~ /MSWin32/) {
		untie *STDOUT;
	}
	for ( @ARGV) {
		if ( /^-(.*)/) {
			for ( split(' *', lc $1)) {
				if ( $_ eq 'v') {
					$verbose = 1;
				} elsif ( $_ eq 'x') {
					$noX11 = 1; 
				} elsif ( $_ eq 'd') {
					$tie = 0;
				}
			}
		} else {
			push( @filters, $_);
		}
	}
	tie *STDOUT, 'ExTiedStdOut', 0 if $tie;

	unless ( $noX11) {
		eval "use Prima::Application name => 'failtester';"; die $@ if $@;
		$w = Prima::Window-> create(
			onDestroy => sub { $::application-> close},
			size => [ 200,200],
		);
	} else {
	print <<NOX11;
** Warning: skipping X11 tests
NOX11
	}
}

sub run
{
	rundir('.');
	print("Atomic tests passed:$passed, skipped:$skipped, failed:$failed\n") if $verbose;
	print("Total tests passed:$epassed, skipped:$eskipped, failed:$efailed\n");
	print("All tests successful\n") unless $efailed; # fake Test::Harness output for CPAN::reporter
}