File Coverage

blib/lib/B/XPath.pm

Criterion	Covered	Total	%
statement	159	221	71.9
branch	20	32	62.5
condition	4	6	66.6
subroutine	44	71	61.9
pod	3	3	100.0
total	230	333	69.0

package B::XPath;

use strict;
use warnings;

our $VERSION = '0.01';

use B;
use Scalar::Util 'blessed';

sub fetch_root
{
	my ($class, $sub) = @_;
	my $op            = B::svref_2object( $sub )->ROOT();
	my $op_class      = $class->find_op_class( $op );
	return $op_class->create( root => $op );
}

sub fetch_main_root
{
	my ($class)  = @_;
	my $op       = B::main_root();
	my $op_class = $class->find_op_class( $op );
	return $op_class->create( root => $op );
}

sub find_op_class
{
	my ($class, $op)  = @_;
	my $node_class    =  blessed( $op );
	$node_class       =~ s/(::\w+)$/::XPath$1/;
	return $node_class;
}

package B::XPath::Node;

use Class::XPath
	get_name       => 'name',
	get_parent     => 'parent',
	get_root       => 'get_root',
	get_children   => 'get_children',
	get_attr_names => 'get_attr_names',
	get_attr_value => 'get_attr_value',
	get_content    => 'get_content';

sub create
{
	my ($class, %args)   = @_;
	my $self             = \%args;
	@args{qw( op root )} = ($args{root}, $self) unless $args{op};

	bless $self, $class;

	$self->create_children();
	return $self;
}

sub get_root
{
	my $self = shift;
	return $self->{root};
}

sub op
{
	my $self = shift;
	return $self->{op};
}

sub parent
{
	my $self = shift;
	return unless exists $self->{parent};
	return $self->{parent};
}

sub create_children
{
	my $self = shift;
	my $root = $self->get_root();
	my $kids = $self->{children} = [];

	for my $kid ($self->kids())
	{
		my $kid_class = B::XPath->find_op_class( $kid );
		push @$kids, $kid_class->create(
			op     => $kid,
			root   => $root,
			parent => $self,
		);
	}
}

sub kids
{
	my $self = shift;
	return unless $self->name() eq 'null';
}

sub get_children
{
	my $self = shift;
	return unless $self->{children};
	return @{ $self->{children} };
}

sub get_name
{
	my $self = shift;
	return $self->name();
}

sub DESTROY {}

sub AUTOLOAD
{
	our $AUTOLOAD;
	my $self     = $_[0];
	my ($method) = $AUTOLOAD =~ /::(\w+)$/;
	my $op       = $self->op();

	die "Unimplemented method $method for $self\n" unless $op->can( $method );
	my $sub = sub { shift->op()->$method() };
	no strict 'refs';
	*{ Scalar::Util::blessed( $self ) . '::' . $method } = $sub;
	goto &$sub;
}

sub get_attr_value
{
	my ($self, $attr) = @_;
	my $op            = $self->op();
	return unless $op->can( $attr );
	return $op->$attr();
}

sub get_nextstate
{
	my $self = shift;
	return $self->{nextstate} if $self->{nextstate};
	$self->{nextstate} = $self->find_nextstate();
}

sub find_nextstate
{
	my $self   = shift;
	my $parent = $self->parent();

	my $nextstate;

	for my $sibling ( $parent->get_children() )
	{
		last if $sibling eq $self;
		next unless $sibling->name() eq 'nextstate';
		$nextstate = $sibling;
	}

	return $nextstate if defined $nextstate;
	return $parent->find_nextstate();
}

sub get_line
{
	my $self      = shift;
	my $nextstate = $self->get_nextstate();
	return $nextstate->line();
}

sub get_file
{
	my $self      = shift;
	my $nextstate = $self->get_nextstate();
	return $nextstate->file();
}

sub name
{
	my $self = shift;
	my $name = $self->op()->name();
	return $name unless $name eq 'null';
	return substr( B::ppname( $self->targ() ), 3 );
}

package B::XPath::NULL;

use base 'B::XPath::Node';

package B::XPath::OP;

use base 'B::XPath::Node';

sub get_attr_names
{
	return qw( sibling ppaddr desc targ type opt static flags private spare );
}

sub get_content
{
	my $self = shift;
	return $self->name();
}

package B::XPath::UNOP;

use base 'B::XPath::Node';

sub kids
{
	my $self    = shift;
	my $op      = $self->op();
	my $first   = $op->first();

	my @kids    = $first;
	my $sibling = $first;

	while ($sibling = $sibling->sibling())
	{
		if ($sibling->isa( 'B::NULL' ) and $sibling->can( 'kids' ))
		{
			push @kids, $sibling->kids();
		}
		last if $sibling->isa( 'B::NULL' );
		push @kids, $sibling;
	}

	return @kids;
}

package B::XPath::BINOP;

use base 'B::XPath::UNOP';

sub kids
{
	my $self = shift;
	return $self->SUPER::kids();
}

package B::XPath::LOGOP;

use base 'B::XPath::UNOP';

sub kids
{
	my $self = shift;
	return $self->SUPER::kids(), $self->other();
}

package B::XPath::LISTOP;

use base 'B::XPath::BINOP';

sub kids
{
	my $self    = shift;
	my $op      = $self->op();
	my $first   = $op->first();
	my $last    = $op->last();

	my @kids    = $first;
	my $sibling = $first;

	while ($sibling = $sibling->sibling())
	{
		if ($sibling->isa( 'B::NULL' ) and $sibling->can( 'kids' ))
		{
			push @kids, $sibling->kids();
		}
		last if $sibling->isa( 'B::NULL' );
		push @kids, $sibling;
		last if $sibling == $last;
	}

	return @kids;
}

package B::XPath::LOOP;

use base 'B::XPath::LISTOP';

sub kids
{
	my $self = shift;
	my $op   = $self->op();
	return $op->nextop(), $op->lastop(), $op->redoop();
}

package B::XPath::COP;

use base 'B::XPath::OP';

sub get_attr_names
{
	my $self = shift;
	return $self->SUPER::get_attr_names(),
		qw( label stash stashpv file cop_seq arybase line warnings io );
}

package B::XPath::SVOP;

# this package is different; SVOPs contain GVs/SVs
# however, they don't look like it in the optree
# op() here thus delegates all calls to the contained GV

use base 'B::XPath::OP';

# the parent name() uses op(), which is wrong here
sub name
{
	return $_[0]->{op}->name();
}

# hey, these look like GV attributes!
sub get_attr_names
{
	my $self = shift;
	my @names = $self->SUPER::get_attr_names();
	return @names,
		qw( NAME SAFENAME STASH SV IO FORM AV HV EGV CV CVGEN LINE FILE FILEGV
		GvREFCNT FLAGS );
}

# you don't want me, you want my GV
sub op
{
	my $self = shift;
	return $self->{op}->gv();
}

package B::XPath::PADOP;

use base 'B::XPath::OP';

sub get_attr_names
{
	my $self = shift;
	return $self->SUPER::get_attr_names(), qw( padix );
}

package B::XPath::PVOP;

use base 'B::XPath::OP';

sub get_attr_names
{
	my $self = shift;
	return $self->SUPER::get_attr_names(), qw( pv );
}

package B::XPath::SV;

use base 'B::XPath::Node';

sub get_name
{
	my $self = shift;
	return $self->name();
}

sub get_root       {}
sub get_content    {}
sub get_attr_names {}

package B::XPath::IV;

use base 'B::XPath::SV';

sub get_content
{
	my $self = shift;
	my $op   = shift;
	return $op->int_value();
}

sub get_attr_names
{
	my $self  = shift;
	my @names = $self->SUPER::get_attr_names();
	return @names, qw( needs64bits packiv );
}

package B::XPath::NV;

use base 'B::XPath::IV';

sub get_content
{
	my $self = shift;
	return $self->op()->NV();
}

package B::XPath::RV;

use base 'B::XPath::SV';

sub get_content
{
	my $self = shift;
	return $self->op()->RV();
}

package B::XPath::PV;

use base 'B::XPath::SV';

sub name { 'pv' }

sub get_content
{
	my $self = shift;
	return $self->op()->PV();
}

package B::XPath::PVNV;

use base qw( B::XPath::PV B::XPath::NV );

package B::XPath::PVMG;

use base 'B::XPath::PVNV';

package B::XPath::GV;

use base 'B::XPath::PVMG';

sub name { 'gv' }

sub get_content
{
	my $self = shift;
	return $self->op()->SAFENAME();
}

sub get_attr_names
{
	my $self  = shift;
	my @names = $self->SUPER::get_attr_names();
	return @names,
		qw( NAME SAFENAME STASH SV IO FORM AV HV EGV CV CVGEN LINE FILE FILEGV
		GvREFCNT FLAGS );
}

1;
__END__