From 21427fe4d2b0e8237dc6a30b69a8f41b945b46ec Mon Sep 17 00:00:00 2001
From: dakkar <dakkar@thenautilus.net>
Date: Wed, 12 Aug 2009 17:22:06 +0200
Subject: added back-compatibility

actually tested it: 02-back-compat passes on both PPIx::XPath 1.0.0 and
PPIx::XPath 2.0
---
 Makefile.PL        |  2 ++
 lib/PPIx/XPath.pm  | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/01-use.t         |  3 ++
 t/02-back-compat.t | 23 ++++++++++++++
 4 files changed, 117 insertions(+)
 create mode 100644 t/01-use.t
 create mode 100644 t/02-back-compat.t

diff --git a/Makefile.PL b/Makefile.PL
index e183799..5a37bda 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -6,6 +6,8 @@ all_from 'lib/PPIx/XPath.pm';
 
 requires 'Tree::XPathEngine' => 0,
          'PPI'               => '1.2',
+         'Scalar::Util'      => 0,
+         'Carp'              => 0,
          'perl'              => '5.6.0',
 ;
 
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)=@_;
diff --git a/t/01-use.t b/t/01-use.t
new file mode 100644
index 0000000..9848444
--- /dev/null
+++ b/t/01-use.t
@@ -0,0 +1,3 @@
+#!perl
+use Test::Most tests=>1,'bail';
+use_ok('PPIx::XPath');
diff --git a/t/02-back-compat.t b/t/02-back-compat.t
new file mode 100644
index 0000000..e8bc3e4
--- /dev/null
+++ b/t/02-back-compat.t
@@ -0,0 +1,23 @@
+#!perl
+use Test::Most tests=>3,'die';
+use strict;
+use warnings;
+use PPI;
+use PPIx::XPath;
+
+my $x=PPIx::XPath->new(\<<'EOF');
+sub foo { print "bar" }
+
+baz();
+EOF
+
+#explain('the doc: ',$x->{doc});
+
+my ($subdef) = $x->match('/Statement::Sub');
+is($subdef->name,'foo','Got the sub');
+
+my ($string) = $x->match('/Statement::Sub/Structure::Block/Statement/Token::Quote::Double');
+is($string->string,'bar','Got the string');
+
+my ($call) = $x->match('/Statement/Token::Word');
+is($call->literal,'baz','Got the call');
-- 
cgit v1.2.3