#!/usr/bin/perl

# Exhaustively test all possible Perl programs to a particular length

use strict;
use Carp 'croak';
BEGIN {
	no warnings 'once';
	$| = 1;
	$PPI::XS_DISABLE = 1;
	$PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER};
}

use vars qw{$MAX_CHARS $ITERATIONS $LENGTH @ALL_CHARS};
BEGIN {
	# When distributing, keep this in to verify the test script
	# is working correctly, but limit to 2 (maaaaybe 3) so we
	# don't slow the install process down too much.
	$MAX_CHARS  = 2;
	$ITERATIONS = 1000;
	$LENGTH     = 190;
	@ALL_CHARS  = (
		qw{a b c f g m q r s t w x y z V W X 0 1 8 9},
		';', '[', ']', '{', '}', '(', ')', '=', '?', '|', '+', '<',
		'>', '.', '!', '~', '^', '*', '$', '@', '&', ':', '%', ',',
		'\\', '/', '_', ' ', "\n", "\t", '-',
		 "'", '"', '`', '#', # Comment out to make parsing more intense
		);
	#my @ALL_CHARS = (
	#	qw{a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H
	#	I J K L M N O P Q R S T U V W X Y Z 0 1 2 3 4 5 6 7 8 9},
	#	';', '[', ']', '{', '}', '(', ')', '=', '?', '|', '+', '<', '>', '.',
	#	'!', '~', '^', '*', '$', '@', '&', ':', '%', '#', ',', "'", '"', '`',
	#	'\\', '/', '_', ' ', "\n", "\t", '-',
	#	);
}





#####################################################################
# Prepare

use Test::More tests => ($MAX_CHARS + $ITERATIONS + 3);
use Test::NoWarnings;
use File::Spec::Functions ':ALL';
use Params::Util qw{_INSTANCE};
use PPI;





#####################################################################
# Retest Previous Failures

test_code2( "( {8" );





#####################################################################
# Code/Dump Testing

my $failures   = 0;
my $last_index = scalar(@ALL_CHARS) - 1;
LENGTHLOOP:
foreach my $len ( 1 .. $MAX_CHARS ) {
	# Initialise the char array and failure count
	my $failures = 0;
	my @chars    = (0) x $len;

	# The main test loop
	CHARLOOP:
	while ( 1 ) {
		# Test the current set of chars
		my $code = join '', map { $ALL_CHARS[$_] } @chars;
		unless ( length($code) == $len ) {
			die "Failed sanity check. Error in the code generation mechanism";
		}
		test_code( $code );

		# Increment the last character
		$chars[$len - 1]++;

		# Cascade the wrapping as needed
		foreach ( reverse( 0 .. $len - 1 ) ) {
			next CHARLOOP unless $chars[$_] > $last_index;
			if ( $_ == 0 ) {
				# End of the iterations, move to the next length
				last CHARLOOP;
			}

			# Carry to the previous char
			$chars[$_] = 0;
			$chars[$_ - 1]++;
		}
	}
	is( $failures, 0, "No tokenizer failures for all $len-length programs" );
}





#####################################################################
# Test a series of random strings

my $count = 0;
foreach my $i ( 1 .. $ITERATIONS ) {
	# Generate a random string
	my $code = join( '',
		map { $ALL_CHARS[$_] }
		map { int(rand($last_index) + 1) }
		(1 .. $LENGTH)
		);

	# Test it as normal
	test_code2( $code );

	# Verify there are no stale %PARENT entries
	#my $quotable = quotable($code);
	#is( scalar(keys %PPI::Element::PARENT), 0,
	#	"%PARENT is clean \"$quotable\"" );
}

is( scalar(keys %PPI::Element::PARENT), 0,
	'No stale \%PARENT entries at the end of testing' );
%PPI::Element::PARENT = %PPI::Element::PARENT;





#####################################################################
# Support Functions

sub test_code2 {
	$failures    = 0;
	my $string   = shift;
	my $quotable = quotable($string);
	test_code( $string );
	is( $failures, 0, "String parses ok \"$quotable\"" );	
}

sub test_code {
	my $code      = shift;
	my $Document  = eval {
		# $SIG{__WARN__} = sub { croak('Triggered a warning') };
		PPI::Document->new(\$code);
	};

	# Version of the code for use in error messages
	my $quotable = quotable($code);
	unless ( _INSTANCE($Document, 'PPI::Document') ) {
		$failures++;
		diag( "\"$quotable\": Parser did not return a Document" );
		return;
	}
	my $joined          = $Document->serialize;
	my $joined_quotable = quotable($joined);
	unless ( $joined eq $code ) {
		$failures++;
		diag( "\"$quotable\": Document round-trips ok" );
		diag( "\"$joined_quotable\" (round-trips to)" );
		return;
	}
}

# Find the shortest failing substring of known bad string
sub quickcheck {
	my $code       = shift;
	my $fails      = $code;
	# $SIG{__WARN__} = sub { croak('Triggered a warning') };

	while ( length $fails ) {
		chop $code;
		my $Document = PPI::Document->new(\$code) or last;
		$fails = $code;
	}

	while ( length $fails ) {
		substr( $code, 0, 1, '' );
		my $Document = PPI::Document->new(\$code) or return $fails;
		$fails = $code;
	}

	return $fails;
}

sub quotable {
	my $quotable = shift;
	$quotable =~ s/\\/\\\\/g;
	$quotable =~ s/\t/\\t/g;
	$quotable =~ s/\n/\\n/g;
	$quotable =~ s/\$/\\\$/g;
	$quotable =~ s/\@/\\\@/g;
	$quotable =~ s/\"/\\\"/g;
	return $quotable;
}

exit(0);