802 lines
20 KiB
Perl
802 lines
20 KiB
Perl
|
package PPI::Node;
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
PPI::Node - Abstract PPI Node class, an Element that can contain other Elements
|
||
|
|
|
||
|
|
=head1 INHERITANCE
|
||
|
|
|
||
|
|
PPI::Node
|
||
|
|
isa PPI::Element
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
# Create a typical node (a Document in this case)
|
||
|
|
my $Node = PPI::Document->new;
|
||
|
|
|
||
|
|
# Add an element to the node( in this case, a token )
|
||
|
|
my $Token = PPI::Token::Word->new('my');
|
||
|
|
$Node->add_element( $Token );
|
||
|
|
|
||
|
|
# Get the elements for the Node
|
||
|
|
my @elements = $Node->children;
|
||
|
|
|
||
|
|
# Find all the barewords within a Node
|
||
|
|
my $barewords = $Node->find( 'PPI::Token::Word' );
|
||
|
|
|
||
|
|
# Find by more complex criteria
|
||
|
|
my $my_tokens = $Node->find( sub { $_[1]->content eq 'my' } );
|
||
|
|
|
||
|
|
# Remove all the whitespace
|
||
|
|
$Node->prune( 'PPI::Token::Whitespace' );
|
||
|
|
|
||
|
|
# Remove by more complex criteria
|
||
|
|
$Node->prune( sub { $_[1]->content eq 'my' } );
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
The C<PPI::Node> class provides an abstract base class for the Element
|
||
|
|
classes that are able to contain other elements L<PPI::Document>,
|
||
|
|
L<PPI::Statement>, and L<PPI::Structure>.
|
||
|
|
|
||
|
|
As well as those listed below, all of the methods that apply to
|
||
|
|
L<PPI::Element> objects also apply to C<PPI::Node> objects.
|
||
|
|
|
||
|
|
=head1 METHODS
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use Carp ();
|
||
|
|
use Scalar::Util qw{refaddr};
|
||
|
|
use List::Util ();
|
||
|
|
use Params::Util qw{_INSTANCE _CLASS _CODELIKE _NUMBER};
|
||
|
|
use PPI::Element ();
|
||
|
|
use PPI::Singletons '%_PARENT';
|
||
|
|
|
||
|
|
our $VERSION = '1.270'; # VERSION
|
||
|
|
|
||
|
|
our @ISA = "PPI::Element";
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
# The basic constructor
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my $class = ref $_[0] || $_[0];
|
||
|
|
bless { children => [] }, $class;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
# PDOM Methods
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 scope
|
||
|
|
|
||
|
|
The C<scope> method returns true if the node represents a lexical scope
|
||
|
|
boundary, or false if it does not.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
### XS -> PPI/XS.xs:_PPI_Node__scope 0.903+
|
||
|
|
sub scope() { '' }
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 add_element $Element
|
||
|
|
|
||
|
|
The C<add_element> method adds a L<PPI::Element> object to the end of a
|
||
|
|
C<PPI::Node>. Because Elements maintain links to their parent, an
|
||
|
|
Element can only be added to a single Node.
|
||
|
|
|
||
|
|
Returns true if the L<PPI::Element> was added. Returns C<undef> if the
|
||
|
|
Element was already within another Node, or the method is not passed
|
||
|
|
a L<PPI::Element> object.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub add_element {
|
||
|
|
my $self = shift;
|
||
|
|
|
||
|
|
# Check the element
|
||
|
|
my $Element = _INSTANCE(shift, 'PPI::Element') or return undef;
|
||
|
|
$_PARENT{refaddr $Element} and return undef;
|
||
|
|
|
||
|
|
# Add the argument to the elements
|
||
|
|
push @{$self->{children}}, $Element;
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr $Element} = $self
|
||
|
|
);
|
||
|
|
|
||
|
|
1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# In a typical run profile, add_element is the number 1 resource drain.
|
||
|
|
# This is a highly optimised unsafe version, for internal use only.
|
||
|
|
sub __add_element {
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr $_[1]} = $_[0]
|
||
|
|
);
|
||
|
|
push @{$_[0]->{children}}, $_[1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 elements
|
||
|
|
|
||
|
|
The C<elements> method accesses all child elements B<structurally> within
|
||
|
|
the C<PPI::Node> object. Note that in the base of the L<PPI::Structure>
|
||
|
|
classes, this C<DOES> include the brace tokens at either end of the
|
||
|
|
structure.
|
||
|
|
|
||
|
|
Returns a list of zero or more L<PPI::Element> objects.
|
||
|
|
|
||
|
|
Alternatively, if called in the scalar context, the C<elements> method
|
||
|
|
returns a count of the number of elements.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub elements {
|
||
|
|
if ( wantarray ) {
|
||
|
|
return @{$_[0]->{children}};
|
||
|
|
} else {
|
||
|
|
return scalar @{$_[0]->{children}};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 first_element
|
||
|
|
|
||
|
|
The C<first_element> method accesses the first element structurally within
|
||
|
|
the C<PPI::Node> object. As for the C<elements> method, this does include
|
||
|
|
the brace tokens for L<PPI::Structure> objects.
|
||
|
|
|
||
|
|
Returns a L<PPI::Element> object, or C<undef> if for some reason the
|
||
|
|
C<PPI::Node> object does not contain any elements.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
# Normally the first element is also the first child
|
||
|
|
sub first_element {
|
||
|
|
$_[0]->{children}->[0];
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 last_element
|
||
|
|
|
||
|
|
The C<last_element> method accesses the last element structurally within
|
||
|
|
the C<PPI::Node> object. As for the C<elements> method, this does include
|
||
|
|
the brace tokens for L<PPI::Structure> objects.
|
||
|
|
|
||
|
|
Returns a L<PPI::Element> object, or C<undef> if for some reason the
|
||
|
|
C<PPI::Node> object does not contain any elements.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
# Normally the last element is also the last child
|
||
|
|
sub last_element {
|
||
|
|
$_[0]->{children}->[-1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 children
|
||
|
|
|
||
|
|
The C<children> method accesses all child elements lexically within the
|
||
|
|
C<PPI::Node> object. Note that in the case of the L<PPI::Structure>
|
||
|
|
classes, this does B<NOT> include the brace tokens at either end of the
|
||
|
|
structure.
|
||
|
|
|
||
|
|
Returns a list of zero of more L<PPI::Element> objects.
|
||
|
|
|
||
|
|
Alternatively, if called in the scalar context, the C<children> method
|
||
|
|
returns a count of the number of lexical children.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
# In the default case, this is the same as for the elements method
|
||
|
|
sub children {
|
||
|
|
wantarray ? @{$_[0]->{children}} : scalar @{$_[0]->{children}};
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 schildren
|
||
|
|
|
||
|
|
The C<schildren> method is really just a convenience, the significant-only
|
||
|
|
variation of the normal C<children> method.
|
||
|
|
|
||
|
|
In list context, returns a list of significant children. In scalar context,
|
||
|
|
returns the number of significant children.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub schildren {
|
||
|
|
return grep { $_->significant } @{$_[0]->{children}} if wantarray;
|
||
|
|
my $count = 0;
|
||
|
|
foreach ( @{$_[0]->{children}} ) {
|
||
|
|
$count++ if $_->significant;
|
||
|
|
}
|
||
|
|
return $count;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 child $index
|
||
|
|
|
||
|
|
The C<child> method accesses a child L<PPI::Element> object by its
|
||
|
|
position within the Node.
|
||
|
|
|
||
|
|
Returns a L<PPI::Element> object, or C<undef> if there is no child
|
||
|
|
element at that node.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub child {
|
||
|
|
my ( $self, $index ) = @_;
|
||
|
|
PPI::Exception->throw( "method child() needs an index" )
|
||
|
|
if not defined _NUMBER $index;
|
||
|
|
$self->{children}->[$index];
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 schild $index
|
||
|
|
|
||
|
|
The lexical structure of the Perl language ignores 'insignificant' items,
|
||
|
|
such as whitespace and comments, while L<PPI> treats these items as valid
|
||
|
|
tokens so that it can reassemble the file at any time. Because of this,
|
||
|
|
in many situations there is a need to find an Element within a Node by
|
||
|
|
index, only counting lexically significant Elements.
|
||
|
|
|
||
|
|
The C<schild> method returns a child Element by index, ignoring
|
||
|
|
insignificant Elements. The index of a child Element is specified in the
|
||
|
|
same way as for a normal array, with the first Element at index 0, and
|
||
|
|
negative indexes used to identify a "from the end" position.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub schild {
|
||
|
|
my $self = shift;
|
||
|
|
my $idx = 0 + shift;
|
||
|
|
my $el = $self->{children};
|
||
|
|
if ( $idx < 0 ) {
|
||
|
|
my $cursor = 0;
|
||
|
|
while ( exists $el->[--$cursor] ) {
|
||
|
|
return $el->[$cursor] if $el->[$cursor]->significant and ++$idx >= 0;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
my $cursor = -1;
|
||
|
|
while ( exists $el->[++$cursor] ) {
|
||
|
|
return $el->[$cursor] if $el->[$cursor]->significant and --$idx < 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 contains $Element
|
||
|
|
|
||
|
|
The C<contains> method is used to determine if another L<PPI::Element>
|
||
|
|
object is logically "within" a C<PPI::Node>. For the special case of the
|
||
|
|
brace tokens at either side of a L<PPI::Structure> object, they are
|
||
|
|
generally considered "within" a L<PPI::Structure> object, even if they are
|
||
|
|
not actually in the elements for the L<PPI::Structure>.
|
||
|
|
|
||
|
|
Returns true if the L<PPI::Element> is within us, false if not, or C<undef>
|
||
|
|
on error.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub contains {
|
||
|
|
my $self = shift;
|
||
|
|
my $Element = _INSTANCE(shift, 'PPI::Element') or return undef;
|
||
|
|
|
||
|
|
# Iterate up the Element's parent chain until we either run out
|
||
|
|
# of parents, or get to ourself.
|
||
|
|
while ( $Element = $Element->parent ) {
|
||
|
|
return 1 if refaddr($self) == refaddr($Element);
|
||
|
|
}
|
||
|
|
|
||
|
|
'';
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 find $class | \&wanted
|
||
|
|
|
||
|
|
The C<find> method is used to search within a code tree for
|
||
|
|
L<PPI::Element> objects that meet a particular condition.
|
||
|
|
|
||
|
|
To specify the condition, the method can be provided with either a simple
|
||
|
|
class name (full or shortened), or a C<CODE>/function reference.
|
||
|
|
|
||
|
|
# Find all single quotes in a Document (which is a Node)
|
||
|
|
$Document->find('PPI::Quote::Single');
|
||
|
|
|
||
|
|
# The same thing with a shortened class name
|
||
|
|
$Document->find('Quote::Single');
|
||
|
|
|
||
|
|
# Anything more elaborate, we go with the sub
|
||
|
|
$Document->find( sub {
|
||
|
|
# At the top level of the file...
|
||
|
|
$_[1]->parent == $_[0]
|
||
|
|
and (
|
||
|
|
# ...find all comments and POD
|
||
|
|
$_[1]->isa('PPI::Token::Pod')
|
||
|
|
or
|
||
|
|
$_[1]->isa('PPI::Token::Comment')
|
||
|
|
)
|
||
|
|
} );
|
||
|
|
|
||
|
|
The function will be passed two arguments, the top-level C<PPI::Node>
|
||
|
|
you are searching in and the current L<PPI::Element> that the condition
|
||
|
|
is testing.
|
||
|
|
|
||
|
|
The anonymous function should return one of three values. Returning true
|
||
|
|
indicates a condition match, defined-false (C<0> or C<''>) indicates
|
||
|
|
no-match, and C<undef> indicates no-match and no-descend.
|
||
|
|
|
||
|
|
In the last case, the tree walker will skip over anything below the
|
||
|
|
C<undef>-returning element and move on to the next element at the same
|
||
|
|
level.
|
||
|
|
|
||
|
|
To halt the entire search and return C<undef> immediately, a condition
|
||
|
|
function should throw an exception (i.e. C<die>).
|
||
|
|
|
||
|
|
Note that this same wanted logic is used for all methods documented to
|
||
|
|
have a C<\&wanted> parameter, as this one does.
|
||
|
|
|
||
|
|
The C<find> method returns a reference to an array of L<PPI::Element>
|
||
|
|
objects that match the condition, false (but defined) if no Elements match
|
||
|
|
the condition, or C<undef> if you provide a bad condition, or an error
|
||
|
|
occurs during the search process.
|
||
|
|
|
||
|
|
In the case of a bad condition, a warning will be emitted as well.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub find {
|
||
|
|
my $self = shift;
|
||
|
|
my $wanted = $self->_wanted(shift) or return undef;
|
||
|
|
|
||
|
|
# Use a queue based search, rather than a recursive one
|
||
|
|
my @found;
|
||
|
|
my @queue = @{$self->{children}};
|
||
|
|
my $ok = eval {
|
||
|
|
while ( @queue ) {
|
||
|
|
my $Element = shift @queue;
|
||
|
|
my $rv = &$wanted( $self, $Element );
|
||
|
|
push @found, $Element if $rv;
|
||
|
|
|
||
|
|
# Support "don't descend on undef return"
|
||
|
|
next unless defined $rv;
|
||
|
|
|
||
|
|
# Skip if the Element doesn't have any children
|
||
|
|
next unless $Element->isa('PPI::Node');
|
||
|
|
|
||
|
|
# Depth-first keeps the queue size down and provides a
|
||
|
|
# better logical order.
|
||
|
|
if ( $Element->isa('PPI::Structure') ) {
|
||
|
|
unshift @queue, $Element->finish if $Element->finish;
|
||
|
|
unshift @queue, @{$Element->{children}};
|
||
|
|
unshift @queue, $Element->start if $Element->start;
|
||
|
|
} else {
|
||
|
|
unshift @queue, @{$Element->{children}};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
1;
|
||
|
|
};
|
||
|
|
if ( !$ok ) {
|
||
|
|
# Caught exception thrown from the wanted function
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
@found ? \@found : '';
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 find_first $class | \&wanted
|
||
|
|
|
||
|
|
If the normal C<find> method is like a grep, then C<find_first> is
|
||
|
|
equivalent to the L<List::Util> C<first> function.
|
||
|
|
|
||
|
|
Given an element class or a wanted function, it will search depth-first
|
||
|
|
through a tree until it finds something that matches the condition,
|
||
|
|
returning the first Element that it encounters.
|
||
|
|
|
||
|
|
See the C<find> method for details on the format of the search condition.
|
||
|
|
|
||
|
|
Returns the first L<PPI::Element> object that matches the condition, false
|
||
|
|
if nothing matches the condition, or C<undef> if given an invalid condition,
|
||
|
|
or an error occurs.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub find_first {
|
||
|
|
my $self = shift;
|
||
|
|
my $wanted = $self->_wanted(shift) or return undef;
|
||
|
|
|
||
|
|
# Use the same queue-based search as for ->find
|
||
|
|
my @queue = @{$self->{children}};
|
||
|
|
my $rv;
|
||
|
|
my $ok = eval {
|
||
|
|
# The defined() here prevents a ton of calls to PPI::Util::TRUE
|
||
|
|
while ( @queue ) {
|
||
|
|
my $Element = shift @queue;
|
||
|
|
my $element_rv = $wanted->( $self, $Element );
|
||
|
|
if ( $element_rv ) {
|
||
|
|
$rv = $Element;
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Support "don't descend on undef return"
|
||
|
|
next if !defined $element_rv;
|
||
|
|
|
||
|
|
# Skip if the Element doesn't have any children
|
||
|
|
next if !$Element->isa('PPI::Node');
|
||
|
|
|
||
|
|
# Depth-first keeps the queue size down and provides a
|
||
|
|
# better logical order.
|
||
|
|
if ( $Element->isa('PPI::Structure') ) {
|
||
|
|
unshift @queue, $Element->finish if defined($Element->finish);
|
||
|
|
unshift @queue, @{$Element->{children}};
|
||
|
|
unshift @queue, $Element->start if defined($Element->start);
|
||
|
|
} else {
|
||
|
|
unshift @queue, @{$Element->{children}};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
1;
|
||
|
|
};
|
||
|
|
if ( !$ok ) {
|
||
|
|
# Caught exception thrown from the wanted function
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
$rv or '';
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 find_any $class | \&wanted
|
||
|
|
|
||
|
|
The C<find_any> method is a short-circuiting true/false method that behaves
|
||
|
|
like the normal C<find> method, but returns true as soon as it finds any
|
||
|
|
Elements that match the search condition.
|
||
|
|
|
||
|
|
See the C<find> method for details on the format of the search condition.
|
||
|
|
|
||
|
|
Returns true if any Elements that match the condition can be found, false if
|
||
|
|
not, or C<undef> if given an invalid condition, or an error occurs.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub find_any {
|
||
|
|
my $self = shift;
|
||
|
|
my $rv = $self->find_first(@_);
|
||
|
|
$rv ? 1 : $rv; # false or undef
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 remove_child $Element
|
||
|
|
|
||
|
|
If passed a L<PPI::Element> object that is a direct child of the Node,
|
||
|
|
the C<remove_element> method will remove the C<Element> intact, along
|
||
|
|
with any of its children. As such, this method acts essentially as a
|
||
|
|
'cut' function.
|
||
|
|
|
||
|
|
If successful, returns the removed element. Otherwise, returns C<undef>.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub remove_child {
|
||
|
|
my $self = shift;
|
||
|
|
my $child = _INSTANCE(shift, 'PPI::Element') or return undef;
|
||
|
|
|
||
|
|
# Find the position of the child
|
||
|
|
my $key = refaddr $child;
|
||
|
|
my $p = List::Util::first {
|
||
|
|
refaddr $self->{children}[$_] == $key
|
||
|
|
} 0..$#{$self->{children}};
|
||
|
|
return undef unless defined $p;
|
||
|
|
|
||
|
|
# Splice it out, and remove the child's parent entry
|
||
|
|
splice( @{$self->{children}}, $p, 1 );
|
||
|
|
delete $_PARENT{refaddr $child};
|
||
|
|
|
||
|
|
$child;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head2 prune $class | \&wanted
|
||
|
|
|
||
|
|
The C<prune> method is used to strip L<PPI::Element> objects out of a code
|
||
|
|
tree. The argument is the same as for the C<find> method, either a class
|
||
|
|
name, or an anonymous subroutine which returns true/false. Any Element
|
||
|
|
that matches the class|wanted will be deleted from the code tree, along
|
||
|
|
with any of its children.
|
||
|
|
|
||
|
|
The C<prune> method returns the number of C<Element> objects that matched
|
||
|
|
and were removed, B<non-recursively>. This might also be zero, so avoid a
|
||
|
|
simple true/false test on the return false of the C<prune> method. It
|
||
|
|
returns C<undef> on error, which you probably B<should> test for.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub prune {
|
||
|
|
my $self = shift;
|
||
|
|
my $wanted = $self->_wanted(shift) or return undef;
|
||
|
|
|
||
|
|
# Use a depth-first queue search
|
||
|
|
my $pruned = 0;
|
||
|
|
my @queue = $self->children;
|
||
|
|
my $ok = eval {
|
||
|
|
while ( my $element = shift @queue ) {
|
||
|
|
my $rv = &$wanted( $self, $element );
|
||
|
|
if ( $rv ) {
|
||
|
|
# Delete the child
|
||
|
|
$element->delete or return undef;
|
||
|
|
$pruned++;
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Support the undef == "don't descend"
|
||
|
|
next unless defined $rv;
|
||
|
|
|
||
|
|
if ( _INSTANCE($element, 'PPI::Node') ) {
|
||
|
|
# Depth-first keeps the queue size down
|
||
|
|
unshift @queue, $element->children;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
1;
|
||
|
|
};
|
||
|
|
if ( !$ok ) {
|
||
|
|
# Caught exception thrown from the wanted function
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
$pruned;
|
||
|
|
}
|
||
|
|
|
||
|
|
# This method is likely to be very heavily used, so take
|
||
|
|
# it slowly and carefully.
|
||
|
|
### NOTE: Renaming this function or changing either to self will probably
|
||
|
|
### break File::Find::Rule::PPI
|
||
|
|
sub _wanted {
|
||
|
|
my $either = shift;
|
||
|
|
my $it = defined($_[0]) ? shift : do {
|
||
|
|
Carp::carp('Undefined value passed as search condition') if $^W;
|
||
|
|
return undef;
|
||
|
|
};
|
||
|
|
|
||
|
|
# Has the caller provided a wanted function directly
|
||
|
|
return $it if _CODELIKE($it);
|
||
|
|
if ( ref $it ) {
|
||
|
|
# No other ref types are supported
|
||
|
|
Carp::carp('Illegal non-CODE reference passed as search condition') if $^W;
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
# The first argument should be an Element class, possibly in shorthand
|
||
|
|
$it = "PPI::$it" unless substr($it, 0, 5) eq 'PPI::';
|
||
|
|
unless ( _CLASS($it) and $it->isa('PPI::Element') ) {
|
||
|
|
# We got something, but it isn't an element
|
||
|
|
Carp::carp("Cannot create search condition for '$it': Not a PPI::Element") if $^W;
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Create the class part of the wanted function
|
||
|
|
my $wanted_class = "\n\treturn '' unless \$_[1]->isa('$it');";
|
||
|
|
|
||
|
|
# Have we been given a second argument to check the content
|
||
|
|
my $wanted_content = '';
|
||
|
|
if ( defined $_[0] ) {
|
||
|
|
my $content = shift;
|
||
|
|
if ( ref $content eq 'Regexp' ) {
|
||
|
|
$content = "$content";
|
||
|
|
} elsif ( ref $content ) {
|
||
|
|
# No other ref types are supported
|
||
|
|
Carp::carp("Cannot create search condition for '$it': Not a PPI::Element") if $^W;
|
||
|
|
return undef;
|
||
|
|
} else {
|
||
|
|
$content = quotemeta $content;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Complete the content part of the wanted function
|
||
|
|
$wanted_content .= "\n\treturn '' unless defined \$_[1]->{content};";
|
||
|
|
$wanted_content .= "\n\treturn '' unless \$_[1]->{content} =~ /$content/;";
|
||
|
|
}
|
||
|
|
|
||
|
|
# Create the complete wanted function
|
||
|
|
my $code = "sub {"
|
||
|
|
. $wanted_class
|
||
|
|
. $wanted_content
|
||
|
|
. "\n\t1;"
|
||
|
|
. "\n}";
|
||
|
|
|
||
|
|
# Compile the wanted function
|
||
|
|
$code = eval $code;
|
||
|
|
(ref $code eq 'CODE') ? $code : undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
####################################################################
|
||
|
|
# PPI::Element overloaded methods
|
||
|
|
|
||
|
|
sub tokens {
|
||
|
|
map { $_->tokens } @{$_[0]->{children}};
|
||
|
|
}
|
||
|
|
|
||
|
|
### XS -> PPI/XS.xs:_PPI_Element__content 0.900+
|
||
|
|
sub content {
|
||
|
|
join '', map { $_->content } @{$_[0]->{children}};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Clone as normal, but then go down and relink all the _PARENT entries
|
||
|
|
sub clone {
|
||
|
|
my $self = shift;
|
||
|
|
my $clone = $self->SUPER::clone;
|
||
|
|
$clone->__link_children;
|
||
|
|
$clone;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub location {
|
||
|
|
my $self = shift;
|
||
|
|
my $first = $self->{children}->[0] or return undef;
|
||
|
|
$first->location;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
#####################################################################
|
||
|
|
# Internal Methods
|
||
|
|
|
||
|
|
sub DESTROY {
|
||
|
|
local $_;
|
||
|
|
if ( $_[0]->{children} ) {
|
||
|
|
my @queue = $_[0];
|
||
|
|
while ( defined($_ = shift @queue) ) {
|
||
|
|
unshift @queue, @{delete $_->{children}} if $_->{children};
|
||
|
|
|
||
|
|
# Remove all internal/private weird crosslinking so that
|
||
|
|
# the cascading DESTROY calls will get called properly.
|
||
|
|
%$_ = ();
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Remove us from our parent node as normal
|
||
|
|
delete $_PARENT{refaddr $_[0]};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Find the position of a child
|
||
|
|
sub __position {
|
||
|
|
my $key = refaddr $_[1];
|
||
|
|
List::Util::first { refaddr $_[0]{children}[$_] == $key } 0..$#{$_[0]{children}};
|
||
|
|
}
|
||
|
|
|
||
|
|
# Insert one or more elements before a child
|
||
|
|
sub __insert_before_child {
|
||
|
|
my $self = shift;
|
||
|
|
my $key = refaddr shift;
|
||
|
|
my $p = List::Util::first {
|
||
|
|
refaddr $self->{children}[$_] == $key
|
||
|
|
} 0..$#{$self->{children}};
|
||
|
|
foreach ( @_ ) {
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr $_} = $self
|
||
|
|
);
|
||
|
|
}
|
||
|
|
splice( @{$self->{children}}, $p, 0, @_ );
|
||
|
|
1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Insert one or more elements after a child
|
||
|
|
sub __insert_after_child {
|
||
|
|
my $self = shift;
|
||
|
|
my $key = refaddr shift;
|
||
|
|
my $p = List::Util::first {
|
||
|
|
refaddr $self->{children}[$_] == $key
|
||
|
|
} 0..$#{$self->{children}};
|
||
|
|
foreach ( @_ ) {
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr $_} = $self
|
||
|
|
);
|
||
|
|
}
|
||
|
|
splice( @{$self->{children}}, $p + 1, 0, @_ );
|
||
|
|
1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Replace a child
|
||
|
|
sub __replace_child {
|
||
|
|
my $self = shift;
|
||
|
|
my $key = refaddr shift;
|
||
|
|
my $p = List::Util::first {
|
||
|
|
refaddr $self->{children}[$_] == $key
|
||
|
|
} 0..$#{$self->{children}};
|
||
|
|
foreach ( @_ ) {
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr $_} = $self
|
||
|
|
);
|
||
|
|
}
|
||
|
|
splice( @{$self->{children}}, $p, 1, @_ );
|
||
|
|
1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Create PARENT links for an entire tree.
|
||
|
|
# Used when cloning or thawing.
|
||
|
|
sub __link_children {
|
||
|
|
my $self = shift;
|
||
|
|
|
||
|
|
# Relink all our children ( depth first )
|
||
|
|
my @queue = ( $self );
|
||
|
|
while ( my $Node = shift @queue ) {
|
||
|
|
# Link our immediate children
|
||
|
|
foreach my $Element ( @{$Node->{children}} ) {
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr($Element)} = $Node
|
||
|
|
);
|
||
|
|
unshift @queue, $Element if $Element->isa('PPI::Node');
|
||
|
|
}
|
||
|
|
|
||
|
|
# If it's a structure, relink the open/close braces
|
||
|
|
next unless $Node->isa('PPI::Structure');
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr($Node->start)} = $Node
|
||
|
|
) if $Node->start;
|
||
|
|
Scalar::Util::weaken(
|
||
|
|
$_PARENT{refaddr($Node->finish)} = $Node
|
||
|
|
) if $Node->finish;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
=head1 TO DO
|
||
|
|
|
||
|
|
- Move as much as possible to L<PPI::XS>
|
||
|
|
|
||
|
|
=head1 SUPPORT
|
||
|
|
|
||
|
|
See the L<support section|PPI/SUPPORT> in the main module.
|
||
|
|
|
||
|
|
=head1 AUTHOR
|
||
|
|
|
||
|
|
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||
|
|
|
||
|
|
=head1 COPYRIGHT
|
||
|
|
|
||
|
|
Copyright 2001 - 2011 Adam Kennedy.
|
||
|
|
|
||
|
|
This program is free software; you can redistribute
|
||
|
|
it and/or modify it under the same terms as Perl itself.
|
||
|
|
|
||
|
|
The full text of the license can be found in the
|
||
|
|
LICENSE file included with this module.
|
||
|
|
|
||
|
|
=cut
|