B::XPath - search Perl optrees with XPath syntax

B-XPath documentation Contained in the B-XPath distribution.

Index

Code Index:

NAME

Top

B::XPath - search Perl optrees with XPath syntax

SYNOPSIS

Top

Perl represents programs internally as a tree of opcodes. To execute a program, it walks this tree, performing each operation as it encounters it. The B family of modules allows you to examine (and in some cases, manipulate) this optree on programs even as they run.

B::XPath allows you to use XPath syntax to select ops in the optree.

    use B::XPath;

    my $node    = B::XPath->fetch_root( \&some_function );
	my $root    = B::XPath->fetch_main_root();

	# find all global scalar accesses
	my @globals = $root->match( '//gvsv' );

	# find all global scalar accesses within some_function() named $bob
	my @bobs    = $node->match( '//gvsv[@NAME="bob"]' );

Class Methods

Top

There are two methods to use to start your match; both set the root of the tree to search. There's also a nice helper method you'll probably never use unless you find a bug.

fetch_root( $subref )

This method returns the B::XPath::Node object at the root of the optree for the subroutine reference. All matches performed on this node will search this branch of the optree for matching nodes.

fetch_main_root()

This method returns the B::XPath::Node object at the root of the program. Use this to search your entire program (at least, the part of it outside of any given subroutine).

find_op_class( $op )

Given a B::OP or descendent object, returns the name of the appropriate B::XPath::Node subclass to use to wrap that op so that B::XPath can manipulate it appropriately.

Node Methods

Top

There are several methods available on the nodes returned from find or match requests.

match( $xpath_expression )

Given an XPath expression, searches the tree with this node at the root to find all nodes matching the expression. Returns a list of all found nodes.

Note that this does not return the nodes in depth-first order. I think.

create( op = $op, root => $root )>

Creates a new B::XPath::Node object (of the appropriate subclass), setting the op and root parameters. This will descend into all of the op's children, calling create() appropriately.

You probably don't need to know this exists unless you want to fix a bug in the module

get_root()

Returns the root node of the tree from which you searched for this node.

get_parent()

Returns the parent node of this node, if it exists. If this is a root node, it will return nothing.

get_children()

Returns a list of all of the child nodes of this node, if there are any. Otherwise it returns nothing.

get_name()

Returns the name of the op that this node represents.

get_file()

Returns the name of the file containing the node this op represents. This may not always be completely accurate, depending on certain optimizations -- but it tries really hard.

get_line()

Returns the number of the line of course code in which the node this op represents appears. This may not always be completely accurate, depending on certain optimizations -- but it tries really hard.

There are a few other methods available, but I don't want to make them public just yet.

AUTHOR

Top

chromatic, <chromatic at wgz.org>

BUGS

Top

There aren't any, to my knowledge, except that this doesn't support all of XPath. See Class::XPath for more information.

Of course, there's no guarantee that future versions of Perl will create the same optrees ... so there's a chance that this isn't as robust as you might like.

Please report any bugs or feature requests to bug-b-xpath at rt.cpan.org, or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=B-XPath. This will notify me and the system will automatically notify you of progress on your bug as I make changes.

SUPPORT

Top

You may be able to find more information at:

* AnnoCPAN: Annotated CPAN documentation

http://annocpan.org/dist/B-XPath

* CPAN Ratings

http://cpanratings.perl.org/d/B-XPath

* RT: CPAN's request tracker

http://rt.cpan.org/NoAuth/Bugs.html?Dist=B-XPath

* Search CPAN

http://search.cpan.org/dist/B-XPath

COPYRIGHT & LICENSE

Top

Copyright 2006 chromatic, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

See also Perl Hacks, copyright 2006 O'Reilly Media, Inc., which explains more about how to use this module.

B-XPath documentation Contained in the B-XPath distribution. 
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__