summaryrefslogtreecommitdiff
path: root/lib/PPIx/XPath.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/PPIx/XPath.pm')
-rw-r--r--lib/PPIx/XPath.pm89
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)=@_;