1 files changed, 89 insertions, 0 deletions

diff --git a/lib/PPIx/XPath.pm b/lib/PPIx/XPath.pm
index a718ee7..f5cd244 100644
--- a/lib/PPIx/XPath.pm
+++ b/lib/PPIx/XPath.pm
@@ -2,11 +2,88 @@ package PPIx::XPath;
 use strict;
 use warnings;
 use PPI;
+use Carp;
+use Scalar::Util qw(reftype blessed);
+use Tree::XPathEngine;
 use 5.006;
 
 our $VERSION='2.01';
 
+sub new {
+    my ($class,$source) = @_;
+
+    croak "PPIx::XPath->new needs a source document" unless defined($source);
+
+    my $doc;
+    if (blessed($source) && $source->isa('PPI::Node')) {
+        $doc = $source;
+    }
+    elsif (reftype($source) eq 'SCALAR'
+       or (!ref($source) && -f $source)) {
+        $doc = PPI::Document->new($source);
+    }
+    else {
+        croak "PPIx::XPath expects either a PPI::Node or a file" .
+            " got a: [" .( ref($source) || $source ). ']';
+    }
+
+    return bless {doc=>$doc},$class;
+}
+
+# PPIx::XPath 1.0.0 allowed the use of partial package names as node names;
+# this collides with the axis specification of proper XPath.
+# Here we change the "old-style" node names into the new names
+{
+my $legacy_names_rx;my %new_name_for;
+sub clean_xpath_expr {
+    my (undef,$expr)=@_;
+
+    $expr =~ s{$legacy_names_rx}{$new_name_for{$1}}ge;
+
+    return $expr;
+}
+
+    my @PPI_Packs;
+    # taken from Devel::Symdump
+    my @packages=('PPI');
+    while (my $pack=shift(@packages)) {
+        no strict 'refs';
+        while (my ($key,$val)=each(%{*{"$pack\::"}})) {
+            local *ENTRY=$val;
+            if (defined $val && defined *ENTRY{HASH} && $key=~/::$/
+                    && $key !~ /^::/
+                    && $key ne 'main::' && $key ne '<none>::') {
+
+                my $p = "$pack\::$key";$p =~ s{::$}{}; #}{};
+                push @packages,$p;
+                $p =~ s{^PPI::}{};
+
+                next unless $p=~/::/;
+
+                my $newname=$p;
+                $newname =~ s{::}{-}g;
+                push @PPI_Packs,$p;
+                $new_name_for{$p}=$newname;
+            }
+        }
+    }
+    $legacy_names_rx='\b('.join('|',
+                            sort {length($b) <=> length($a)} @PPI_Packs
+                            ).')\b';
+    $legacy_names_rx=qr{$legacy_names_rx};
+}
+
+sub match {
+    my ($self,$expr) = @_;
+
+    $expr=$self->clean_xpath_expr($expr);
+
+    Tree::XPathEngine->new()->findnodes($expr,$self->{doc});
+}
+
 package PPI::Element;
+use strict;
+use warnings;
 
 sub xpath_get_name              { my $pack_name=substr($_[0]->class,5);
                                   $pack_name =~ s/::/-/g;
@@ -96,10 +173,14 @@ sub _xpath_ancestors {
 }
 
 package PPI::Token;
+use strict;
+use warnings;
 
 sub xpath_get_child_nodes       { return }
 
 package PPI::Node;
+use strict;
+use warnings;
 
 sub xpath_get_child_nodes       { $_[0]->schildren }
 sub xpath_get_attributes        {
@@ -108,6 +189,8 @@ sub xpath_get_attributes        {
 }
 
 package PPI::Statement;
+use strict;
+use warnings;
 
 sub xpath_get_attributes        {
     return $_[0]->SUPER::xpath_get_attributes,
@@ -116,6 +199,8 @@ sub xpath_get_attributes        {
 }
 
 package PPI::Structure;
+use strict;
+use warnings;
 
 sub xpath_get_attributes        {
     return $_[0]->SUPER::xpath_get_attributes,
@@ -125,6 +210,8 @@ sub xpath_get_attributes        {
 }
 
 package PPI::Document;
+use strict;
+use warnings;
 
 sub xpath_get_root_node         { $_[0] }
 sub xpath_get_parent_node       { return }
@@ -132,6 +219,8 @@ sub xpath_is_attribute_node     { 0 }
 sub xpath_is_document_node      { 1 }
 
 package PPIx::XPath::Attr;
+use strict;
+use warnings;
 
 sub new {
     my ($class,$parent,$name,$value)=@_;