first apparently working version

docs and tests still needed

1 files changed, 164 insertions, 0 deletions

diff --git a/lib/PPIx/XPath.pm b/lib/PPIx/XPath.pm
index b91bbe1..a718ee7 100644
--- a/lib/PPIx/XPath.pm
+++ b/lib/PPIx/XPath.pm
@@ -6,6 +6,170 @@ use 5.006;
 
 our $VERSION='2.01';
 
+package PPI::Element;
+
+sub xpath_get_name              { my $pack_name=substr($_[0]->class,5);
+                                  $pack_name =~ s/::/-/g;
+                                  $pack_name }
+sub xpath_get_next_sibling      { $_[0]->snext_sibling }
+sub xpath_get_previous_sibling  { $_[0]->sprevious_sibling }
+sub xpath_get_root_node         { $_[0]->top }
+sub xpath_get_parent_node       { $_[0]->parent }
+sub xpath_is_element_node       { 1 }
+sub xpath_is_attribute_node     { 0 }
+sub xpath_is_document_node      { 0 }
+sub xpath_get_attributes        {
+    return
+        PPIx::XPath::Attr->new($_[0],significant => $_[0]->significant),
+        PPIx::XPath::Attr->new($_[0],content => $_[0]->content),
+}
+sub xpath_to_literal            { "$_[0]" }
+
+sub xpath_cmp {
+    my( $a, $b)= @_;
+    if ( UNIVERSAL::isa( $b, 'PPIx::XPath::Attr')) {
+        # elt <=> att, compare the elt to the att->{elt}
+        # if the elt is the att->{elt} (cmp return 0) then -1, elt is before att
+        return ($a->_xpath_elt_cmp( $b->{parent}) ) || -1 ;
+    }
+    elsif ( UNIVERSAL::isa( $b, 'PPI::Document')) {
+        # elt <=> document, elt is after document
+        return 1;
+    } else {
+        # 2 elts, compare them
+        return $a->_xpath_elt_cmp( $b);
+    }
+}
+
+sub _xpath_elt_cmp {
+    my ($a,$b)=@_;
+
+    # easy cases
+    return  0 if( $a == $b);
+    return  1 if( $a->_xpath_in($b)); # a starts after b
+    return -1 if( $b->_xpath_in($a)); # a starts before b
+
+    # ancestors does not include the element itself
+    my @a_pile= ($a, $a->_xpath_ancestors);
+    my @b_pile= ($b, $b->_xpath_ancestors);
+
+    # the 2 elements are not in the same twig
+    return undef unless( $a_pile[-1] == $b_pile[-1]);
+
+    # find the first non common ancestors (they are siblings)
+    my $a_anc= pop @a_pile;
+    my $b_anc= pop @b_pile;
+
+    while( $a_anc == $b_anc) {
+        $a_anc= pop @a_pile;
+        $b_anc= pop @b_pile;
+    }
+
+    # from there move left and right and figure out the order
+    my( $a_prev, $a_next, $b_prev, $b_next)= ($a_anc, $a_anc, $b_anc, $b_anc);
+    while () {
+        $a_prev= $a_prev->sprevious_sibling || return( -1);
+        return 1 if( $a_prev == $b_next);
+        $a_next= $a_next->snext_sibling || return( 1);
+        return -1 if( $a_next == $b_prev);
+        $b_prev= $b_prev->sprevious_sibling || return( 1);
+        return -1 if( $b_prev == $a_next);
+        $b_next= $b_next->snext_sibling || return( -1);
+        return 1 if( $b_next == $a_prev);
+    }
+}
+
+sub _xpath_in {
+    my ($self, $ancestor)= @_;
+    while ( $self= $self->parent) {
+        return $self if ( $self ==  $ancestor);
+    }
+}
+
+sub _xpath_ancestors {
+    my( $self)= @_;
+    my @ancestors;
+    while ( $self= $self->parent) {
+        push @ancestors, $self;
+    }
+    return @ancestors;
+}
+
+package PPI::Token;
+
+sub xpath_get_child_nodes       { return }
+
+package PPI::Node;
+
+sub xpath_get_child_nodes       { $_[0]->schildren }
+sub xpath_get_attributes        {
+    return $_[0]->SUPER::xpath_get_attributes,
+        PPIx::XPath::Attr->new($_[0],scope => $_[0]->scope),
+}
+
+package PPI::Statement;
+
+sub xpath_get_attributes        {
+    return $_[0]->SUPER::xpath_get_attributes,
+        PPIx::XPath::Attr->new($_[0],label => $_[0]->label),
+        PPIx::XPath::Attr->new($_[0],stable => $_[0]->stable),
+}
+
+package PPI::Structure;
+
+sub xpath_get_attributes        {
+    return $_[0]->SUPER::xpath_get_attributes,
+        PPIx::XPath::Attr->new($_[0],start => $_[0]->start),
+        PPIx::XPath::Attr->new($_[0],finish => $_[0]->finish),
+        PPIx::XPath::Attr->new($_[0],braces => $_[0]->braces),
+}
+
+package PPI::Document;
+
+sub xpath_get_root_node         { $_[0] }
+sub xpath_get_parent_node       { return }
+sub xpath_is_attribute_node     { 0 }
+sub xpath_is_document_node      { 1 }
+
+package PPIx::XPath::Attr;
+
+sub new {
+    my ($class,$parent,$name,$value)=@_;
+
+    return unless defined $value;
+
+    return bless {parent=>$parent,name=>$name,value=>$value},$class;
+}
+
+sub xpath_get_name              { $_[0]->{name} }
+sub xpath_get_root_node         { $_[0]->{parent}->top }
+sub xpath_get_parent_node       { $_[0]->{parent} }
+sub xpath_is_element_node       { 0 }
+sub xpath_is_attribute_node     { 1 }
+sub xpath_is_document_node      { 0 }
+sub xpath_to_literal            { $_[0]->{value} }
+sub xpath_get_value             { $_[0]->{value} }
+sub xpath_string_value          { $_[0]->{value} }
+sub xpath_to_number             { Tree::XPathEngine::Number->new($_[0]->{value}) }
+
+sub xpath_cmp($$) {
+    my( $a, $b)= @_;
+    if ( UNIVERSAL::isa( $b, 'PPIx::XPath::Attr')) {
+        # 2 attributes, compare their elements, then their name
+        return ($a->{parent}->_xpath_elt_cmp( $b->{parent}) ) 
+            || ($a->{name} cmp $b->{name});
+    }
+    elsif ( UNIVERSAL::isa( $b, 'PPI::Document')) {
+        # att <=> document, att is after document
+        return 1;
+    }
+    else {
+        # att <=> elt : compare the att->elt and the elt
+        # if att->elt is the elt (cmp returns 0) then 1 (elt is before att)
+        return ($a->{parent}->_xpath_elt_cmp( $b) ) || 1 ;
+    }
+}
+
 1;
 __END__