#!/usr/bin/perl
# Formal testing for PPI
# This does an empiric test that when we try to parse something,
# something ( anything ) comes out the other side.
use lib 't/lib';
use PPI::Test::pragmas;
use Test::More tests => 220 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
use File::Spec::Functions ':ALL';
use PPI;
use Scalar::Util 'refaddr';
use PPI::Test 'pause';
sub is_object {
my ($left, $right, $message) = @_;
$message ||= "Objects match";
my $condition = (
defined $left
and ref $left,
and defined $right,
and ref $right,
and refaddr($left) == refaddr($right)
);
ok( $condition, $message );
}
use vars qw{$RE_IDENTIFIER};
BEGIN {
$RE_IDENTIFIER = qr/[^\W\d]\w*/;
}
sub omethod_fails {
my $object = ref($_[0])->isa('UNIVERSAL') ? shift : die "Failed to pass method_fails test an object";
my $method = (defined $_[0] and $_[0] =~ /$RE_IDENTIFIER/o) ? shift : die "Failed to pass method_fails an identifier";
my $arg_set = ( ref $_[0] eq 'ARRAY' and scalar(@{$_[0]}) ) ? shift : die "Failed to pass method_fails a set of arguments";
foreach my $args ( @$arg_set ) {
is( $object->$method( $args ), undef, ref($object) . "->$method fails correctly" );
}
}
#####################################################################
# Miscellaneous
# Confirm that C< weaken( $hash{scalar} = $object ) > works as expected,
# adding a weak reference to the has index.
use Scalar::Util ();
SCOPE: {
my %hash;
my $counter = 0;
SCOPE: {
my $object1 = bless { }, 'My::WeakenTest';
my $object2 = bless { }, 'My::WeakenTest';
my $object3 = bless { }, 'My::WeakenTest';
isa_ok( $object1, 'My::WeakenTest' );
isa_ok( $object2, 'My::WeakenTest' );
isa_ok( $object3, 'My::WeakenTest' );
# Do nothing for object1.
# Add object2 to a has index normally
$hash{foo} = $object2;
# Add object2 and weaken
Scalar::Util::weaken($hash{bar} = $object3);
ok( Scalar::Util::isweak( $hash{bar} ), 'index entry is weak' );
ok( ! Scalar::Util::isweak( $object3 ), 'original is not weak' );
pause();
# Do all the objects still exist
isa_ok( $object1, 'My::WeakenTest' );
isa_ok( $object2, 'My::WeakenTest' );
isa_ok( $object3, 'My::WeakenTest' );
isa_ok( $hash{foo}, 'My::WeakenTest' );
isa_ok( $hash{bar}, 'My::WeakenTest' );
}
pause();
# Two of the three should have destroyed
is( $counter, 2, 'Counter increments as expected normally' );
# foo should still be there
isa_ok( $hash{foo}, 'My::WeakenTest' );
# bar should ->exists, but be undefined
ok( exists $hash{bar}, 'weakened object hash slot exists' );
ok( ! defined $hash{bar}, 'weakened object hash slot is undefined' );
package My::WeakenTest;
sub DESTROY {
$counter++;
}
}
# Test interaction between weaken and Clone
SCOPE: {
my $object = { a => undef };
# my $object = bless { a => undef }, 'Foo';
my $object2 = $object;
Scalar::Util::weaken($object2);
my $clone = Clone::clone($object);
is_deeply( $clone, $object, 'Object is cloned OK when a different reference is weakened' );
}
#####################################################################
# Prepare
# Build a basic source tree to test with
my $source = 'my@foo = (1, 2);';
my $Document = PPI::Lexer->lex_source( $source );
isa_ok( $Document, 'PPI::Document' );
is( $Document->content, $source, "Document round-trips ok" );
is( scalar($Document->tokens), 12, "Basic source contains the correct number of tokens" );
is( scalar(@{$Document->{children}}), 1, "Document contains one element" );
my $Statement = $Document->{children}->[0];
isa_ok( $Statement, 'PPI::Statement' );
isa_ok( $Statement, 'PPI::Statement::Variable' );
is( scalar(@{$Statement->{children}}), 7, "Statement contains the correct number of elements" );
my $Token1 = $Statement->{children}->[0];
my $Token2 = $Statement->{children}->[1];
my $Token3 = $Statement->{children}->[2];
my $Braces = $Statement->{children}->[5];
my $Token7 = $Statement->{children}->[6];
isa_ok( $Token1, 'PPI::Token::Word' );
isa_ok( $Token2, 'PPI::Token::Symbol' );
isa_ok( $Token3, 'PPI::Token::Whitespace' );
isa_ok( $Braces, 'PPI::Structure::List' );
isa_ok( $Token7, 'PPI::Token::Structure' );
ok( ($Token1->isa('PPI::Token::Word') and $Token1->content eq 'my'), 'First token is correct' );
ok( ($Token2->isa('PPI::Token::Symbol') and $Token2->content eq '@foo'), 'Second token is correct' );
ok( ($Token3->isa('PPI::Token::Whitespace') and $Token3->content eq ' '), 'Third token is correct' );
is( $Braces->braces, '()', 'Braces seem correct' );
ok( ($Token7->isa('PPI::Token::Structure') and $Token7->content eq ';'), 'Seventh token is correct' );
isa_ok( $Braces->start, 'PPI::Token::Structure' );
ok( ($Braces->start->isa('PPI::Token::Structure') and $Braces->start->content eq '('),
'Start brace token matches expected' );
isa_ok( $Braces->finish, 'PPI::Token::Structure' );
ok( ($Braces->finish->isa('PPI::Token::Structure') and $Braces->finish->content eq ')'),
'Finish brace token matches expected' );
#####################################################################
# Testing of PPI::Element basic information methods
# Testing the ->content method
is( $Document->content, $source, "Document content is correct" );
is( $Statement->content, $source, "Statement content is correct" );
is( $Token1->content, 'my', "Token content is correct" );
is( $Token2->content, '@foo', "Token content is correct" );
is( $Token3->content, ' ', "Token content is correct" );
is( $Braces->content, '(1, 2)', "Token content is correct" );
is( $Token7->content, ';', "Token content is correct" );
# Testing the ->tokens method
is( scalar($Document->tokens), 12, "Document token count is correct" );
is( scalar($Statement->tokens), 12, "Statement token count is correct" );
isa_ok( $Token1->tokens, 'PPI::Token', "Token token count is correct" );
isa_ok( $Token2->tokens, 'PPI::Token', "Token token count is correct" );
isa_ok( $Token3->tokens, 'PPI::Token', "Token token count is correct" );
is( scalar($Braces->tokens), 6, "Token token count is correct" );
isa_ok( $Token7->tokens, 'PPI::Token', "Token token count is correct" );
# Testing the ->significant method
is( $Document->significant, 1, 'Document is significant' );
is( $Statement->significant, 1, 'Statement is significant' );
is( $Token1->significant, 1, 'Token is significant' );
is( $Token2->significant, 1, 'Token is significant' );
is( $Token3->significant, '', 'Token is significant' );
is( $Braces->significant, 1, 'Token is significant' );
is( $Token7->significant, 1, 'Token is significant' );
#####################################################################
# Testing of PPI::Element navigation
# Test the ->parent method
is( $Document->parent, undef, "Document does not have a parent" );
is_object( $Statement->parent, $Document, "Statement sees document as parent" );
is_object( $Token1->parent, $Statement, "Token sees statement as parent" );
is_object( $Token2->parent, $Statement, "Token sees statement as parent" );
is_object( $Token3->parent, $Statement, "Token sees statement as parent" );
is_object( $Braces->parent, $Statement, "Braces sees statement as parent" );
is_object( $Token7->parent, $Statement, "Token sees statement as parent" );
# Test the special case of parents for the Braces opening and closing braces
is_object( $Braces->start->parent, $Braces, "Start brace sees the PPI::Structure as it's parent" );
is_object( $Braces->finish->parent, $Braces, "Finish brace sees the PPI::Structure as it's parent" );
# Test the ->top method
is_object( $Document->top, $Document, "Document sees itself as top" );
is_object( $Statement->top, $Document, "Statement sees document as top" );
is_object( $Token1->top, $Document, "Token sees document as top" );
is_object( $Token2->top, $Document, "Token sees document as top" );
is_object( $Token3->top, $Document, "Token sees document as top" );
is_object( $Braces->top, $Document, "Braces sees document as top" );
is_object( $Token7->top, $Document, "Token sees document as top" );
# Test the ->document method
is_object( $Document->document, $Document, "Document sees itself as document" );
is_object( $Statement->document, $Document, "Statement sees document correctly" );
is_object( $Token1->document, $Document, "Token sees document correctly" );
is_object( $Token2->document, $Document, "Token sees document correctly" );
is_object( $Token3->document, $Document, "Token sees document correctly" );
is_object( $Braces->document, $Document, "Braces sees document correctly" );
is_object( $Token7->document, $Document, "Token sees document correctly" );
# Test the ->next_sibling method
is( $Document->next_sibling, '', "Document returns false for next_sibling" );
is( $Statement->next_sibling, '', "Statement returns false for next_sibling" );
is_object( $Token1->next_sibling, $Token2, "First token sees second token as next_sibling" );
is_object( $Token2->next_sibling, $Token3, "Second token sees third token as next_sibling" );
is_object( $Braces->next_sibling, $Token7, "Braces sees seventh token as next_sibling" );
is( $Token7->next_sibling, '', 'Last token returns false for next_sibling' );
# More extensive test for next_sibling
SCOPE: {
my $doc = PPI::Document->new( \"sub foo { bar(); }" );
my $end = $doc->last_token;
isa_ok( $end, 'PPI::Token::Structure' );
is( $end->content, '}', 'Got end token' );
is( $end->next_sibling, '', '->next_sibling for an end closing brace returns false' );
my $braces = $doc->find_first( sub {
$_[1]->isa('PPI::Structure') and $_[1]->braces eq '()'
} );
isa_ok( $braces, 'PPI::Structure' );
isa_ok( $braces->next_token, 'PPI::Token::Structure' );
is( $braces->next_token->content, ';', 'Got the correct next_token for structure' );
}
# Test the ->previous_sibling method
is( $Document->previous_sibling, '', "Document returns false for previous_sibling" );
is( $Statement->previous_sibling, '', "Statement returns false for previous_sibling" );
is( $Token1->previous_sibling, '', "First token returns false for previous_sibling" );
is_object( $Token2->previous_sibling, $Token1, "Second token sees first token as previous_sibling" );
is_object( $Token3->previous_sibling, $Token2, "Third token sees second token as previous_sibling" );
is_object( $Token7->previous_sibling, $Braces, "Last token sees braces as previous_sibling" );
# More extensive test for next_sibling
SCOPE: {
my $doc = PPI::Document->new( \"{ no strict; bar(); }" );
my $start = $doc->first_token;
isa_ok( $start, 'PPI::Token::Structure' );
is( $start->content, '{', 'Got start token' );
is( $start->previous_sibling, '', '->previous_sibling for a start opening brace returns false' );
my $braces = $doc->find_first( sub {
$_[1]->isa('PPI::Structure') and $_[1]->braces eq '()'
} );
isa_ok( $braces, 'PPI::Structure' );
isa_ok( $braces->previous_token, 'PPI::Token::Word' );
is( $braces->previous_token->content, 'bar', 'Got the correct previous_token for structure' );
}
# Test the ->snext_sibling method
my $Token4 = $Statement->{children}->[3];
is( $Document->snext_sibling, '', "Document returns false for snext_sibling" );
is( $Statement->snext_sibling, '', "Statement returns false for snext_sibling" );
is_object( $Token1->snext_sibling, $Token2, "First token sees second token as snext_sibling" );
is_object( $Token2->snext_sibling, $Token4, "Second token sees third token as snext_sibling" );
is_object( $Braces->snext_sibling, $Token7, "Braces sees seventh token as snext_sibling" );
is( $Token7->snext_sibling, '', 'Last token returns false for snext_sibling' );
# Test the ->sprevious_sibling method
is( $Document->sprevious_sibling, '', "Document returns false for sprevious_sibling" );
is( $Statement->sprevious_sibling, '', "Statement returns false for sprevious_sibling" );
is( $Token1->sprevious_sibling, '', "First token returns false for sprevious_sibling" );
is_object( $Token2->sprevious_sibling, $Token1, "Second token sees first token as sprevious_sibling" );
is_object( $Token3->sprevious_sibling, $Token2, "Third token sees second token as sprevious_sibling" );
is_object( $Token7->sprevious_sibling, $Braces, "Last token sees braces as sprevious_sibling" );
# Test snext_sibling and sprevious_sibling cases when inside a parent block
SCOPE: {
my $cpan13454 = PPI::Document->new( \'{ 1 }' );
isa_ok( $cpan13454, 'PPI::Document' );
my $num = $cpan13454->find_first('Token::Number');
isa_ok( $num, 'PPI::Token::Number' );
my $prev = $num->sprevious_sibling;
is( $prev, '', '->sprevious_sibling returns false' );
my $next = $num->snext_sibling;
is( $next, '', '->snext_sibling returns false' );
}
#####################################################################
# Test the PPI::Element and PPI::Node analysis methods
# Test the find method
SCOPE: {
is( $Document->find('PPI::Token::End'), '', '->find returns false if nothing found' );
isa_ok( $Document->find('PPI::Structure')->[0], 'PPI::Structure' );
my $found = $Document->find('PPI::Token::Number');
ok( $found, 'Multiple find succeeded' );
is( ref $found, 'ARRAY', '->find returned an array' );
is( scalar(@$found), 2, 'Multiple find returned expected number of items' );
# Test for the ability to shorten the names
$found = $Document->find('Token::Number');
ok( $found, 'Multiple find succeeded' );
is( ref $found, 'ARRAY', '->find returned an array' );
is( scalar(@$found), 2, 'Multiple find returned expected number of items' );
}
# Test for CPAN #7799 - Unsupported element types are accepted by find
#
# The correct behaviour for a bad string is a warning, and return C<undef>
SCOPE: {
local $^W = 0;
is( $Document->find(undef), undef, '->find(undef) failed' );
is( $Document->find([]), undef, '->find([]) failed' );
is( $Document->find('Foo'), undef, '->find(BAD) failed' );
}
# Test the find_first method
SCOPE: {
is( $Document->find_first('PPI::Token::End'), '', '->find_first returns false if nothing found' );
isa_ok( $Document->find_first('PPI::Structure'), 'PPI::Structure' );
my $found = $Document->find_first('PPI::Token::Number');
ok( $found, 'Multiple find_first succeeded' );
isa_ok( $found, 'PPI::Token::Number' );
# Test for the ability to shorten the names
$found = $Document->find_first('Token::Number');
ok( $found, 'Multiple find_first succeeded' );
isa_ok( $found, 'PPI::Token::Number' );
}
# Test the find_any method
SCOPE: {
is( $Document->find_any('PPI::Token::End'), '', '->find_any returns false if nothing found' );
is( $Document->find_any('PPI::Structure'), 1, '->find_any returns true is something found' );
is( $Document->find_any('PPI::Token::Number'), 1, '->find_any returns true for multiple find' );
is( $Document->find_any('Token::Number'), 1, '->find_any returns true for shortened multiple find' );
}
# Test the contains method
SCOPE: {
omethod_fails( $Document, 'contains', [ undef, '', 1, [], bless( {}, 'Foo') ] );
my $found = $Document->find('PPI::Element');
is( ref $found, 'ARRAY', '(preparing for contains tests) ->find returned an array' );
is( scalar(@$found), 15, '(preparing for contains tests) ->find returns correctly for all elements' );
foreach my $Element ( @$found ) {
is( $Document->contains( $Element ), 1, 'Document contains ' . ref($Element) . ' known to be in it' );
}
shift @$found;
foreach my $Element ( @$found ) {
is( $Document->contains( $Element ), 1, 'Statement contains ' . ref($Element) . ' known to be in it' );
}
}
#####################################################################
# Test the PPI::Element manipulation methods
# Cloning an Element/Node
SCOPE: {
my $Doc2 = $Document->clone;
isa_ok( $Doc2, 'PPI::Document' );
isa_ok( $Doc2->schild(0), 'PPI::Statement' );
is_object( $Doc2->schild(0)->parent, $Doc2, 'Basic parent links stay intact after ->clone' );
is_object( $Doc2->schild(0)->schild(3)->start->document, $Doc2,
'Clone goes deep, and Structure braces get relinked properly' );
isnt( refaddr($Document), refaddr($Doc2),
'Cloned Document has a different memory location' );
isnt( refaddr($Document->schild(0)), refaddr($Doc2->schild(0)),
'Cloned Document has children at different memory locations' );
}
# Delete the second token
ok( $Token2->delete, "Deletion of token 2 returns true" );
is( $Document->content, 'my = (1, 2);', "Content is modified correctly" );
is( scalar($Document->tokens), 11, "Modified source contains the correct number of tokens" );
ok( ! defined $Token2->parent, "Token 2 is detached from parent" );
# Delete the braces
ok( $Braces->delete, "Deletion of braces returns true" );
is( $Document->content, 'my = ;', "Content is modified correctly" );
is( scalar($Document->tokens), 5, "Modified source contains the correct number of tokens" );
ok( ! defined $Braces->parent, "Braces are detached from parent" );
#####################################################################
# Test DESTROY
# Start with DESTROY for an element that never has a parent
SCOPE: {
my $Token = PPI::Token::Whitespace->new( ' ' );
my $k1 = scalar keys %PPI::Element::_PARENT;
$Token->DESTROY;
my $k2 = scalar keys %PPI::Element::_PARENT;
is( $k1, $k2, '_PARENT key count remains unchanged after naked Element DESTROY' );
}
# Next, a single element within a parent
SCOPE: {
my $k1 = scalar keys %PPI::Element::_PARENT;
my $k2;
my $k3;
SCOPE: {
my $Token = PPI::Token::Number->new( '1' );
my $Statement = PPI::Statement->new;
$Statement->add_element( $Token );
$k2 = scalar keys %PPI::Element::_PARENT;
is( $k2, $k1 + 1, 'PARENT keys increases after adding element' );
$Statement->DESTROY;
}
pause();
$k3 = scalar keys %PPI::Element::_PARENT;
is( $k3, $k1, 'PARENT keys returns to original on DESTROY' );
}
# Repeat for an entire (large) file
SCOPE: {
my $k1 = scalar keys %PPI::Element::_PARENT;
my $k2;
my $k3;
SCOPE: {
my $NodeDocument = PPI::Document->new( $INC{"PPI/Node.pm"} );
isa_ok( $NodeDocument, 'PPI::Document' );
$k2 = scalar keys %PPI::Element::_PARENT;
ok( $k2 > ($k1 + 3000), 'PARENT keys increases after loading document' );
$NodeDocument->DESTROY;
}
pause();
$k3 = scalar keys %PPI::Element::_PARENT;
is( $k3, $k1, 'PARENT keys returns to original on explicit Document DESTROY' );
}
# Repeat again, but with an implicit DESTROY
SCOPE: {
my $k1 = scalar keys %PPI::Element::_PARENT;
my $k2;
my $k3;
SCOPE: {
my $NodeDocument = PPI::Document->new( $INC{"PPI/Node.pm"} );
isa_ok( $NodeDocument, 'PPI::Document' );
$k2 = scalar keys %PPI::Element::_PARENT;
ok( $k2 > ($k1 + 3000), 'PARENT keys increases after loading document' );
}
pause();
$k3 = scalar keys %PPI::Element::_PARENT;
is( $k3, $k1, 'PARENT keys returns to original on implicit Document DESTROY' );
}
#####################################################################
# Token-related methods
# Test first_token, last_token, next_token and previous_token
SCOPE: {
my $code = <<'END_PERL';
my $foo = bar();
sub foo {
my ($foo, $bar, undef) = ('a', shift(@_), 'bar');
return [ $foo, $bar ];
}
END_PERL
# Trim off the trailing newline to test last_token better
$code =~ s/\s+$//s;
# Create the document
my $doc = PPI::Document->new( \$code );
isa_ok( $doc, 'PPI::Document' );
# Basic first_token and last_token using a single non-trival sample
### FIXME - Make this more thorough
my $first_token = $doc->first_token;
isa_ok( $first_token, 'PPI::Token::Word' );
is( $first_token->content, 'my', '->first_token works as expected' );
my $last_token = $doc->last_token;
isa_ok( $last_token, 'PPI::Token::Structure' );
is( $last_token->content, '}', '->last_token works as expected' );
# Test next_token
is( $last_token->next_token, '', 'last->next_token returns false' );
is( $doc->next_token, '', 'doc->next_token returns false' );
my $next_token = $first_token->next_token;
isa_ok( $next_token, 'PPI::Token::Whitespace' );
is( $next_token->content, ' ', 'Trivial ->next_token works as expected' );
my $counter = 1;
my $token = $first_token;
while ( $token = $token->next_token ) {
$counter++;
}
is( $counter, scalar($doc->tokens),
'->next_token iterated the expected number of times for a sample document' );
# Test previous_token
is( $first_token->previous_token, '', 'last->previous_token returns false' );
is( $doc->previous_token, '', 'doc->previous_token returns false' );
my $previous_token = $last_token->previous_token;
isa_ok( $previous_token, 'PPI::Token::Whitespace' );
is( $previous_token->content, "\n", 'Trivial ->previous_token works as expected' );
$counter = 1;
$token = $last_token;
while ( $token = $token->previous_token ) {
$counter++;
}
is( $counter, scalar($doc->tokens),
'->previous_token iterated the expected number of times for a sample document' );
}
#####################################################################
# Simple overload tests
# Make sure the 'use overload' is working on Element subclasses
SCOPE: {
my $source = '1;';
my $Document = PPI::Lexer->lex_source( $source );
isa_ok( $Document, 'PPI::Document' );
ok($Document eq $source, 'overload eq');
ok($Document ne 'foo', 'overload ne');
ok($Document == $Document, 'overload ==');
ok($Document != $Document->schild(0), 'overload !=');
}