#!/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};
}

# For each new item in t/data/08_regression add another 15 tests
use Test::More tests => 896;
use Test::NoWarnings;
use File::Spec::Functions ':ALL';
use Params::Util qw{_INSTANCE};
use t::lib::PPI;
use PPI::Lexer;
use PPI::Dumper;

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





#####################################################################
# Code/Dump Testing
# ntests = 2 + 14 * nfiles

t::lib::PPI->run_testdir(qw{ t data 08_regression });





#####################################################################
# Regression Test for rt.cpan.org #11522

# Check that objects created in a foreach don't leak circulars.
is( scalar(keys(%PPI::Element::_PARENT)), 0, 'No parent links initially' );
foreach ( 1 .. 3 ) {
	pause();
	is( scalar(keys(%PPI::Element::_PARENT)), 0, 'No parent links at start of loop time' );
	my $Document = PPI::Document->new(\q[print "Foo!"]);
	is( scalar(keys(%PPI::Element::_PARENT)), 4, 'Correct number of keys created' );
}





#####################################################################
# A number of things picked up during exhaustive testing I want to 
# watch for regressions on

# Create a document with a complete braced regexp
SCOPE: {
	my $Document = PPI::Document->new( \"s {foo} <bar>i" );
	isa_ok( $Document, 'PPI::Document' );
	my $stmt   = $Document->first_element;
	isa_ok( $stmt, 'PPI::Statement' );
	my $regexp = $stmt->first_element;
	isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' );

	# Check the regexp matches what we would expect (specifically
	# the fine details about the sections.
	my $expected = {
		_sections => 2,
		braced    => 1,
		content   => 's {foo} <bar>i',
		modifiers => { i => 1 },
		operator  => 's',
		sections  => [ {
			position => 3,
			size     => 3,
			type     => '{}',
		}, {
			position => 9,
			size     => 3,
			type     => '<>',
		} ],
		separator => undef,
	};
	is_deeply( { %$regexp }, $expected, 'Complex regexp matches expected' );
}

# Also test the handling of a screwed up single part multi-regexp
SCOPE: {
	my $Document = PPI::Document->new( \"s {foo}_" );
	isa_ok( $Document, 'PPI::Document' );
	my $stmt   = $Document->first_element;
	isa_ok( $stmt, 'PPI::Statement' );
	my $regexp = $stmt->first_element;
	isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' );

	# Check the internal details as before
	my $expected = {
		_sections => 2,
		_error    => "No second section of regexp, or does not start with a balanced character",
		braced    => 1,
		content   => 's {foo}',
		modifiers => {},
		operator  => 's',
		sections  => [ {
			position => 3,
			size     => 3,
			type     => '{}',
		}, {
			position => 7,
			size     => 0,
			type     => '',
		} ],
		separator => undef,
	};
	is_deeply( { %$regexp }, $expected, 'Badly short regexp matches expected' );
}

# Encode an assumption that the value of a zero-length substr one char
# after the end of the string returns ''. This assuption is used to make
# the decision on the sections->[1]->{position} value being one char after
# the end of the current string
is( substr('foo', 3, 0), '', 'substr one char after string end returns ""' );

# rt.cpan.org: Ticket #16671 $_ is not localized 
# Apparently I DID fix the localisation during parsing, but I forgot to 
# localise in PPI::Node::DESTROY (ack).
$_ = 1234;
is( $_, 1234, 'Set $_ to 1234' );
SCOPE: {
	my $Document = PPI::Document->new( \"print 'Hello World';");
	isa_ok( $Document, 'PPI::Document' );
}
is( $_, 1234, 'Remains after document creation and destruction' );





#####################################################################
# Bug 16815: location of Structure::List is not defined.

SCOPE: {
	my $code = '@foo = (1,2)';
	my $doc = PPI::Document->new(\$code);
	isa_ok( $doc, 'PPI::Document' );
	ok( $doc->find_first('Structure::List')->location, '->location for a ::List returns true' );
}





#####################################################################
# Bug 18413: PPI::Node prune() implementation broken

SCOPE: {
	my $doc = PPI::Document->new( \<<'END_PERL' );
#!/usr/bin/perl

use warnings;

sub one { 1 }
sub two { 2 }
sub three { 3 }

print one;
print "\n";
print three;
print "\n";

exit;
END_PERL
	isa_ok( $doc, 'PPI::Document' );
	ok( defined $doc->prune('PPI::Statement::Sub'), '->prune ok' );
}





#####################################################################
# Bug 19883: 'package' bareword used as hash key is detected as package statement

SCOPE: {
	my $doc = PPI::Document->new( \'(package => 123)' );
	isa_ok( $doc, 'PPI::Document' );
	isa_ok( $doc->child(0)->child(0)->child(0), 'PPI::Statement' );
	isa_ok( $doc->child(0)->child(0)->child(0), 'PPI::Statement::Expression' );
}





#####################################################################
# Bug 19629: End of list mistakenly seen as end of statement

SCOPE: {
	my $doc = PPI::Document->new( \'()' );
	isa_ok( $doc, 'PPI::Document' );
	isa_ok( $doc->child(0), 'PPI::Statement' );
}

SCOPE: {
	my $doc = PPI::Document->new( \'{}' );
	isa_ok( $doc, 'PPI::Document' );
	isa_ok( $doc->child(0), 'PPI::Statement' );
}

SCOPE: {
	my $doc = PPI::Document->new( \'[]' );
	isa_ok( $doc, 'PPI::Document' );
	isa_ok( $doc->child(0), 'PPI::Statement' );
}





#####################################################################
# Bug 21571: PPI::Token::Symbol::symbol does not properly handle
#            variables with adjacent braces

SCOPE: {
	my $doc = PPI::Document->new( \'$foo{bar}' );
	my $symbol = $doc->child(0)->child(0);
	isa_ok( $symbol, 'PPI::Token::Symbol' );
	is( $symbol->symbol, '%foo', 'symbol() for $foo{bar}' );
}

SCOPE: {
	my $doc = PPI::Document->new( \'$foo[0]' );
	my $symbol = $doc->child(0)->child(0);
	isa_ok( $symbol, 'PPI::Token::Symbol' );
	is( $symbol->symbol, '@foo', 'symbol() for $foo[0]' );
}


SCOPE: {
	my $doc = PPI::Document->new( \'@foo{bar}' );
	my $symbol = $doc->child(0)->child(0);
	isa_ok( $symbol, 'PPI::Token::Symbol' );
	is( $symbol->symbol, '%foo', 'symbol() for @foo{bar}' );
}





#####################################################################
# Bug 21575: PPI::Statement::Variable::variables breaks for lists
#            with leading whitespace

SCOPE: {
	my $doc = PPI::Document->new( \'my ( $self, $param ) = @_;' );
	my $stmt = $doc->child(0);
	isa_ok( $stmt, 'PPI::Statement::Variable' );
	is_deeply( [$stmt->variables], ['$self', '$param'], 'variables() for my list with whitespace' );
}





#####################################################################
# Bug #23788: PPI::Statement::location() returns undef for C<({})>.

SCOPE: {
	my $doc = PPI::Document->new( \'({})' );
	isa_ok( $doc, 'PPI::Document' );

	my $bad = $doc->find( sub {
		not defined $_[1]->location
	} );
	is( $bad, '', 'All elements return defined for ->location' );
}





#####################################################################
# Chris Laco on users@perlcritic.tigris.org (sorry no direct URL...)
#   http://perlcritic.tigris.org/servlets/SummarizeList?listName=users
# Empty constructor has no location

SCOPE: {
	my $doc = PPI::Document->new( \'$h={};' );
	my $hash = $doc->find('PPI::Structure::Constructor')->[0];
	ok($hash, 'location for empty constructor - fetched a constructor');
	is_deeply( $hash->location, [1,4,4,1,undef], 'location for empty constructor');
}





#####################################################################
# Perl::MinimumVersion regression

SCOPE: {
	my $doc = PPI::Document->new( \'use utf8;' );
	my $stmt = $doc->child(0);
	isa_ok( $stmt, 'PPI::Statement::Include' );
	is( $stmt->pragma, 'utf8', 'pragma() with numbers' );
}





#####################################################################
# Proof that _new_token must return "1"

SCOPE: {
	my $doc = PPI::Document->new(\<<'END_PERL');
$$content =~ s/(?:\015{1,2}\012|\015|\012)/\n/gs;
END_PERL
	isa_ok( $doc, 'PPI::Document' );
}