#!/usr/bin/perl

# code/dump-style regression tests for known lexing problems.

# Some other regressions tests are included here for simplicity.

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

use File::Spec::Functions ':ALL';

use PPI::Lexer;
use PPI::Dumper;
use Carp 'croak';
use Params::Util qw{_INSTANCE};

sub pause {
	local $@;
	sleep 1 if !eval { require Time::HiRes; Time::HiRes::sleep(0.1); 1 };
}





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

use vars qw{@FAILURES};
BEGIN {
	@FAILURES = (
		# Failed cases 3 chars or less
		'!%:', '!%:',  '!%:',  '!%:',  '!*:', '!@:',  '%:',  '%:,',
		'%:;', '*:',   '*:,',  '*::',  '*:;', '+%:',  '+*:', '+@:',
		'-%:', '-*:',  '-@:',  ';%:',  ';*:', ';@:',  '@:',  '@:,',
		'@::', '@:;',  '\%:',  '\&:',  '\*:', '\@:',  '~%:', '~*:',
		'~@:', '(<',   '(<',   '=<',   'm(',  'm(',   'm<',  'm[',
		'm{',  'q(',   'q<',   'q[',   'q{',  's(',   's<',  's[',
		's{',  'y(',   'y<',   'y[',   'y{',  '$\'0', '009', '0bB',
		'0xX', '009;', '0bB;', '0xX;', "<<'", '<<"',  '<<`', '&::',
		'<<a', '<<V',  '<<s',  '<<y',  '<<_',

		# Failed cases 4 chars long.
		# This isn't the complete set, as they tend to fail in groups
		# of 50 or so, but I've used a representative sample.
		'm;;_', 'm[]_', 'm]]_', 'm{}_', 'm}}_', 'm--_', 's[]a', 's[]b',
		's[]0', 's[];', 's[]]', 's[]=', 's[].', 's[]_', 's{}]', 's{}?',
		's<>s', 's<>-',
		'*::0', '*::1', '*:::', '*::\'', '$::0',  '$:::', '$::\'',
		'@::0', '@::1', '@:::', '&::0',  '&::\'', '%:::', '%::\'',

		# More-specific single cases thrown up during the heavy testing
		'$:::z', '*:::z', "\\\@::'9:!", "} mz}~<<ts", "<\@<<q-r8\n/",
		"W<<s`[\n(", "X<<f+X;g(<~\" \n1\n*", "c<<t* 9\ns\n~^{s ",
		"<<V=-<<Wt", "[<<g/.<<r>\nV"
		);
}

use Test::More tests => 1 + scalar(@FAILURES) * 3;
use Test::NoWarnings;





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

foreach my $code ( @FAILURES ) {
	test_code( $code );

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

exit(0);





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

sub test_code {
	my $code     = shift;
	my $quotable = quotable($code);
	my $Document = eval {
		# $SIG{__WARN__} = sub { croak('Triggered a warning') };
		PPI::Document->new(\$code);
	};
	ok( _INSTANCE($Document, 'PPI::Document'),
		"\"$quotable\": Document parses ok" );
	unless ( _INSTANCE($Document, 'PPI::Document') ) {
		diag( "\"$quotable\": Parsing failed" );
		my $short = quotable(quickcheck($code));
		diag( "Shortest failing substring: \"$short\"" );
		return;		
	}

	# Version of the code for use in error messages
	my $joined          = $Document->serialize;
	my $joined_quotable = quotable($joined);
	is( $joined, $code,
		"\"$quotable\": Document round-trips ok: \"$joined_quotable\"" );
}

# 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;
		PPI::Document->new(\$code) or last;
		$fails = $code;
	}

	while ( length $fails ) {
		substr( $code, 0, 1, '' );
		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;
	return $quotable;
}