File Coverage

blib/lib/MDOM/Node.pm

Criterion	Covered	Total	%
statement	147	229	64.1
branch	48	114	42.1
condition	5	12	41.6
subroutine	30	43	69.7
pod	20	21	95.2
total	250	419	59.6

package MDOM::Node;

=pod

=head1 NAME

MDOM::Node - Abstract MDOM Node class, an Element that can contain other Elements

=head1 INHERITANCE

  MDOM::Node
  isa MDOM::Element

=head1 SYNOPSIS

  # Create a typical node (a Document in this case)
  my $Node = MDOM::Document->new;

  # Add an element to the node( in this case, a token )
  my $Token = MDOM::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( 'MDOM::Token::Word' );

  # Find by more complex criteria
  my $my_tokens = $Node->find( sub { $_[1]->content eq 'my' } );

  # Remove all the whitespace
  $Node->prune( 'MDOM::Token::Whitespace' );

  # Remove by more complex criteria
  $Node->prune( sub { $_[1]->content eq 'my' } );

=head1 DESCRIPTION

The C class provides an abstract base class for the Element
classes that are able to contain other elements L,
L, and L.

As well as those listed below, all of the methods that apply to
L objects also apply to C objects.

=head1 METHODS

=cut

use strict;
use base 'MDOM::Element';
use Carp            ();
use Scalar::Util    'refaddr';
use List::MoreUtils ();
use Params::Util    '_INSTANCE',
                    '_CLASS';

use vars qw{$VERSION *_PARENT};
BEGIN {
	$VERSION = '0.008';
	*_PARENT = *MDOM::Element::_PARENT;
}





#####################################################################
# The basic constructor

sub new {
	my $class = ref $_[0] || $_[0];
	bless { children => [], lineno => $. }, $class;
}


#####################################################################
# PDOM Methods

=pod

=head2 scope

The C method returns true if the node represents a lexical scope
boundary, or false if it does not.

=cut

### XS -> MDOM/XS.xs:_MDOM_Node__scope 0.903+
sub scope { '' }

=pod

=head2 add_element $Element

The C method adds a L object to the end of a
C. Because Elements maintain links to their parent, an
Element can only be added to a single Node.

Returns true if the L was added. Returns C if the
Element was already within another Node, or the method is not passed
a L object.

=cut

sub add_element {
	my $self = shift;

	# Check the element
	my $Element = _INSTANCE(shift, 'MDOM::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];
}

sub __add_elements {
    my $self = shift;
    for (@_) { $self->__add_element($_); }
}

=pod

=head2 elements

The C method accesses all child elements B within
the C object. Note that in the base of the L
classes, this C include the brace tokens at either end of the
structure.

Returns a list of zero or more L objects.

Alternatively, if called in the scalar context, the C method
returns a count of the number of elements.

=cut

sub elements {
	wantarray ? @{$_[0]->{children}} : scalar @{$_[0]->{children}};
}

=pod

=head2 first_element

The C method accesses the first element structurally within
the C object. As for the C method, this does include
the brace tokens for L objects.

Returns a L object, or C if for some reason the
C 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 method accesses the last element structurally within
the C object. As for the C method, this does include
the brace tokens for L objects.

Returns a L object, or C if for some reason the
C 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 method accesses all child elements lexically within the
C object. Note that in the case of the L
classes, this does B include the brace tokens at either end of the
structure.

Returns a list of zero of more L objects.

Alternatively, if called in the scalar context, the C 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 method is really just a convenience, the significant-only
variation of the normal C method.

In list context, returns a list of significant children. In scalar context,
returns the number of significant children.

=cut

sub schildren {
	my $self      = shift;
	my @schildren = grep { $_->significant } $self->children;
	wantarray ? @schildren : scalar(@schildren);
}

=pod

=head2 child $index

The C method accesses a child L object by its
position within the Node.

Returns a L object, or C if there is no child
element at that node.

=cut

sub child {
	$_[0]->{children}->[$_[1]];
}

=pod

=head2 schild $index

The lexical structure of the Perl language ignores 'insignificant' items,
such as whitespace and comments, while L 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 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 method is used to determine if another L
object is logically "within" a C. For the special case of the
brace tokens at either side of a L object, they are
generally considered "within" a L object, even if they are
not actually in the elements for the L.

Returns true if the L is within us, false if not, or C
on error.

=cut

sub contains {
	my $self    = shift;
	my $Element = _INSTANCE(shift, 'MDOM::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 method is used to search within a code tree for
L 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/function reference.

  # Find all single quotes in a Document (which is a Node)
  $Document->find('MDOM::Quote::Single');

  # The same thing with a shortened class name
  $Document->find('Quote::Single');

  # Anything more elaborate, we so with the sub
  $Document->find( sub {
  	# At the top level of the file...
  	$_[1]->parent == $_[0]
  	and (
  		# ...find all comments and POD
  		$_[1]->isa('MDOM::Token::Pod')
  		or
  		$_[1]->isa('MDOM::Token::Comment')
  	)
  } );

The function will be passed two arguments, the top-level C
you are searching in and the current L 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 indicates no-match and no-descend.

In the last case, the tree walker will skip over anything below the
C-returning element and move on to the next element at the same
level.

To halt the entire search and return C immediately, a condition
function should throw an exception (i.e. C).

Note that this same wanted logic is used for all methods documented to
have a C<\&wanted> parameter, as this one does.

The C method returns a reference to an array of L
objects that match the condition, false (but defined) if no Elements match
the condition, or C 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;
	eval {
		while ( 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('MDOM::Node');

			# Depth-first keeps the queue size down and provides a
			# better logical order.
			if ( $Element->isa('MDOM::Structure') ) {
				unshift @queue, $Element->finish if $Element->finish;
				unshift @queue, $Element->children;
				unshift @queue, $Element->start if $Element->start;
			} else {
				unshift @queue, $Element->children;
			}
		}
	};
	if ( $@ ) {
		# Caught exception thrown from the wanted function
		return undef;
	}

	@found ? \@found : '';
}

=pod

=head2 find_first $class | \&wanted

If the normal C method is like a grep, then C is
equivalent to the L C 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 method for details on the format of the search condition.

Returns the first L object that matches the condition, false
if nothing matches the condition, or C 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 = eval {
		while ( my $Element = shift @queue ) {
			my $rv = &$wanted( $self, $Element );
			return $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('MDOM::Node');

			# Depth-first keeps the queue size down and provides a
			# better logical order.
			if ( $Element->isa('MDOM::Structure') ) {
				unshift @queue, $Element->finish if $Element->finish;
				unshift @queue, $Element->children;
				unshift @queue, $Element->start  if $Element->start;
			} else {
				unshift @queue, $Element->children;
			}
		}
	};
	if ( $@ ) {
		# Caught exception thrown from the wanted function
		return undef;
	}

	$rv or '';
}

=pod

=head2 find_any $class | \&wanted

The C method is a short-circuiting true/false method that behaves
like the normal C method, but returns true as soon as it finds any
Elements that match the search condition.

See the C 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 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 object that is a direct child of the Node,
the C method will remove the C intact, along
with any of its children. As such, this method acts essentially as a
'cut' function.

=cut

sub remove_child {
	my $self  = shift;
	my $child = _INSTANCE(shift, 'MDOM::Element') or return undef;

	# Find the position of the child
	my $key = refaddr $child;
	my $p   = List::MoreUtils::firstidx {
		refaddr $_ == $key
		} @{$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 source

Returns the makefile source for the current node

=cut

sub source {
    my $self = shift;
    join '', map { $_->source } $self->children;
}

=pod

=head2 prune $class | \&wanted

The C method is used to strip L objects out of a code
tree. The argument is the same as for the C 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 method returns the number of C objects that matched
and were removed, B. This might also be zero, so avoid a
simple true/false test on the return false of the C method. It
returns C on error, which you probably B 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;
	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, 'MDOM::Node') ) {
				# Depth-first keeps the queue size down
				unshift @queue, $element->children;
			}
		}
	};
	if ( $@ ) {
		# Caught exception thrown from the wanted function
		return undef;
	}

	$pruned;
}

# This method is likely to be very heavily used, to take
# it slowly and carefuly.
### NOTE: Renaming this function or changing either to self will probably
###       break File::Find::Rule::MDOM
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 ref $it eq 'CODE';
	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 = "MDOM::$it" unless substr($it, 0, 6) eq 'MDOM::';
	unless ( _CLASS($it) and $it->isa('MDOM::Element') ) {
		# We got something, but it isn't an element
		Carp::carp("Cannot create search condition for '$it': Not a MDOM::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 MDOM::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;
}





####################################################################
# MDOM::Element overloaded methods

sub tokens {
	map { $_->tokens } @{$_[0]->{children}};
}

### XS -> MDOM/XS.xs:_MDOM_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::MoreUtils::firstidx { refaddr $_ == $key } @{$_[0]->{children}};
}

# Insert one or more elements before a child
sub __insert_before_child {
	my $self = shift;
	my $key  = refaddr shift;
	my $p    = List::MoreUtils::firstidx {
	         refaddr $_ == $key
	         } @{$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::MoreUtils::firstidx {
	         refaddr $_ == $key
	         } @{$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::MoreUtils::firstidx {
	         refaddr $_ == $key
	         } @{$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('MDOM::Node');
		}

		# If it's a structure, relink the open/close braces
		next unless $Node->isa('MDOM::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

=head1 SUPPORT

See the L in the main module.

=head1 AUTHOR

Adam Kennedy [e-mail]

=head1 COPYRIGHT

Copyright 2001 - 2006 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