← Back to branch summary

~ubuntu-branches/ubuntu/vivid/libhtml-selector-xpath-perl/vivid-proposed

« back to all changes in this revision

Viewing changes to lib/HTML/Selector/XPath.pm

  • Committer: Package Import Robot
  • Author(s): gregor herrmann, gregor herrmann, Salvatore Bonaccorso
  • Date: 2014-10-26 13:39:37 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20141026133937-8fuyc8bqvu5fvhy9
Tags: 0.18-1
[ gregor herrmann ]
* Strip trailing slash from metacpan URLs.

[ Salvatore Bonaccorso ]
* Update Vcs-Browser URL to cgit web frontend

[ gregor herrmann ]
* Add debian/upstream/metadata
* Import upstream version 0.18
* Update years of packaging copyright.
* Mark package as autopkgtest-able.
* Declare compliance with Debian Policy 3.9.6.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/HTML/Selector/XPath.pm
2
2
 
3
3
use strict;
4
4
use 5.008_001;
5
 
our $VERSION = '0.16';
 
5
our $VERSION = '0.18';
6
6
 
7
7
require Exporter;
8
8
our @EXPORT_OK = qw(selector_to_xpath);
20
20
 
21
21
my $reg = {
22
22
    # tag name/id/class
23
 
    element => qr/^([#.]?)([a-z0-9\\*_-]*)((\|)([a-z0-9\\*_-]*))?/i,
 
23
    element => qr/^([#.]?)([^\s'"#.\/:@,=~>()\[\]|]*)((\|)([a-z0-9\\*_-]*))?/i,
24
24
    # attribute presence
25
25
    attr1   => qr/^\[ \s* ($ident) \s* \]/x,
26
26
    # attribute value match
36
36
    comma => qr/^\s*,\s*/i,
37
37
};
38
38
 
39
 
 
40
39
sub new {
41
40
    my($class, $exp) = @_;
42
41
    bless { expression => $exp }, $class;
62
61
    } elsif ($op eq '^=') {
63
62
        "starts-with(\@$left,'$^N')";
64
63
    } elsif ($op eq '$=') {
65
 
        "ends-with(\@$left,'$^N')";
 
64
        my $n = length($^N) - 1;
 
65
        "substring(\@$left,string-length(\@$left)-$n)='$^N'";
66
66
    } else { # exact match
67
67
        "\@$left='$^N'";
68
68
    }
69
 
};
 
69
}
70
70
 
71
71
sub _generate_child {
72
72
    my ($direction,$a,$b) = @_;
78
78
    } else { # -an + $b
79
79
        $a = -$a;
80
80
        return "[not((count($direction-sibling::*)+1)>$b) and (($b - (count($direction-sibling::*) + 1)) mod $a) = 0 and parent::*]"
81
 
    };
82
 
};
 
81
    }
 
82
}
83
83
 
84
84
sub nth_child {
85
85
    my ($a,$b) = @_;
86
86
    if (@_ == 1) {
87
87
        ($a,$b) = (0,$a);
88
 
    };
 
88
    }
89
89
    _generate_child('preceding', $a, $b);
90
 
};
 
90
}
91
91
 
92
92
sub nth_last_child {
93
93
    my ($a,$b) = @_;
94
94
    if (@_ == 1) {
95
95
        ($a,$b) = (0,$a);
96
 
    };
 
96
    }
97
97
    _generate_child('following', $a, $b);
98
 
};
 
98
}
99
99
 
100
100
sub to_xpath {
101
101
    my $self = shift;
107
107
    my $last_rule = '';
108
108
    my @next_parts;
109
109
 
110
 
    my $tag;
111
110
    my $wrote_tag;
112
 
    my $tag_index;
113
111
    my $root_index = 0; # points to the current root
114
112
    # Loop through each "unit" of the rule
115
113
    while (length $rule && $rule ne $last_rule) {
122
120
        # (that is, if we start with a combinator)
123
121
        if ($rule =~ /$reg->{combinator}/) {
124
122
            $rule = "* $rule";
125
 
        };
 
123
        }
126
124
 
127
125
        # Match elements
128
126
        if ($rule =~ s/$reg->{element}//) {
134
132
                @next_parts = ();
135
133
            }
136
134
 
137
 
            if ($id_class eq '') {
138
 
                $tag = $name || '*';
139
 
            } else {
140
 
                $tag = '*';
141
 
            }
 
135
            my $tag = $id_class eq '' ? $name || '*' : '*';
142
136
            
143
137
            if (defined $parms{prefix} and not $tag =~ /[*:|]/) {
144
138
                $tag = join ':', $parms{prefix}, $tag;
146
140
            
147
141
            if (! $wrote_tag++) {
148
142
                push @parts, $tag;
149
 
                $tag_index = $#parts;
150
 
            };
 
143
            }
151
144
 
152
145
            # XXX Shouldn't the RE allow both, ID and class?
153
146
            if ($id_class eq '#') { # ID
154
147
                push @parts, "[\@id='$name']";
155
148
            } elsif ($id_class eq '.') { # class
156
 
                push @parts, "[contains(concat(' ', \@class, ' '), ' $name ')]";
 
149
                push @parts, "[contains(concat(' ', normalize-space(\@class), ' '), ' $name ')]";
157
150
            };
158
151
        };
159
152
 
164
157
            # If we have no tag output yet, write the tag:
165
158
            if (! $wrote_tag++) {
166
159
                push @parts, '*';
167
 
                $tag_index = $#parts;
168
 
            };
 
160
            }
169
161
            push @parts, "[\@$1]";
170
162
        } elsif ($rule =~ $reg->{badattr}) {
171
163
            Carp::croak "Invalid attribute-value selector '$rule'";
178
170
                push @parts, "[not(", convert_attribute_match( $1, $2, $^N ), ")]";
179
171
            } elsif ($sub_rule =~ s/$reg->{attr1}//) {
180
172
                push @parts, "[not(\@$1)]";
181
 
            } elsif ($rule =~ $reg->{badattr}) {
182
 
                Carp::croak "Invalid attribute-value selector '$rule'";
 
173
            } elsif ($sub_rule =~ /$reg->{badattr}/) {
 
174
                Carp::croak "Invalid negated attribute-value selector ':not($sub_rule)'";
183
175
            } else {
184
176
                my $xpath = selector_to_xpath($sub_rule);
185
177
                $xpath =~ s!^//!!;
186
178
                push @parts, "[not(self::$xpath)]";
187
 
            #} else {
188
 
            #    Carp::croak "Can't translate '$sub_rule' inside :not()";
189
179
            }
190
180
        }
191
181
 
202
192
                push @parts, nth_child(1), nth_last_child(1);
203
193
            } elsif ($1 =~ /^lang\(([\w\-]+)\)$/) {
204
194
                push @parts, "[\@xml:lang='$1' or starts-with(\@xml:lang, '$1-')]";
 
195
            } elsif ($1 =~ /^nth-child\(odd\)$/) {
 
196
                push @parts, nth_child(2, 1);
 
197
            } elsif ($1 =~ /^nth-child\(even\)$/) {
 
198
                push @parts, nth_child(2, 0);
205
199
            } elsif ($1 =~ /^nth-child\((\d+)\)$/) {
206
200
                push @parts, nth_child($1);
207
201
            } elsif ($1 =~ /^nth-child\((\d+)n(?:\+(\d+))?\)$/) {
235
229
                push @parts, "/";
236
230
            } elsif ($match =~ /\+/) {
237
231
                push @parts, "/following-sibling::*[1]/self::";
238
 
                $tag_index = $#parts;
239
232
            } elsif ($match =~ /\~/) {
240
233
                push @parts, "/following-sibling::";
241
234
            } elsif ($match =~ /^\s*$/) {
245
238
            }
246
239
 
247
240
            # new context
248
 
            undef $tag;
249
241
            undef $wrote_tag;
250
242
        }
251
243
 
253
245
        if ($rule =~ s/$reg->{comma}//) {
254
246
            push @parts, " | ", "$root/"; # ending one rule and beginning another
255
247
            $root_index = $#parts;
256
 
            undef $tag;
257
248
            undef $wrote_tag;
258
249
        }
259
250
    }