lib/PPIx/XPath.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

package PPIx::XPath; 
use strict;
use warnings;
use PPI;
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__
 
=head1 NAME
 
PPIx::XPath - an XPath implementation for the PDOM
 
=head1 AUTHOR
 
Dan Brook <cpan@broquaint.com> original author
 
Gianni Ceccarelli <dakkar@thenautilus.net> Tree::XPathEngine-based re-implementation
 
=cut