Commit | Line | Data |
9a5f1e3f |
1 | package DOM::Tiny::_CSS; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
c256a8c4 |
6 | our $VERSION = '0.003'; |
9a5f1e3f |
7 | |
8 | my $ESCAPE_RE = qr/\\[^0-9a-fA-F]|\\[0-9a-fA-F]{1,6}/; |
9 | my $ATTR_RE = qr/ |
10 | \[ |
11 | ((?:$ESCAPE_RE|[\w\-])+) # Key |
12 | (?: |
13 | (\W)?= # Operator |
14 | (?:"((?:\\"|[^"])*)"|'((?:\\'|[^'])*)'|([^\]]+?)) # Value |
15 | (?:\s+(i))? # Case-sensitivity |
16 | )? |
17 | \] |
18 | /x; |
19 | |
20 | sub new { |
21 | my $class = shift; |
22 | bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class; |
23 | } |
24 | |
25 | sub tree { |
26 | my $self = shift; |
27 | return $self->{tree} unless @_; |
28 | $self->{tree} = shift; |
29 | return $self; |
30 | } |
31 | |
32 | sub matches { |
33 | my $tree = shift->tree; |
34 | return $tree->[0] ne 'tag' ? undef : _match(_compile(shift), $tree, $tree); |
35 | } |
36 | |
37 | sub select { _select(0, shift->tree, _compile(@_)) } |
38 | sub select_one { _select(1, shift->tree, _compile(@_)) } |
39 | |
40 | sub _ancestor { |
41 | my ($selectors, $current, $tree, $one, $pos) = @_; |
42 | |
43 | while ($current = $current->[3]) { |
44 | return undef if $current->[0] eq 'root' || $current eq $tree; |
45 | return 1 if _combinator($selectors, $current, $tree, $pos); |
46 | last if $one; |
47 | } |
48 | |
49 | return undef; |
50 | } |
51 | |
52 | sub _attr { |
53 | my ($name_re, $value_re, $current) = @_; |
54 | |
55 | my $attrs = $current->[2]; |
56 | for my $name (keys %$attrs) { |
57 | next unless $name =~ $name_re; |
58 | return 1 unless defined $attrs->{$name} && defined $value_re; |
59 | return 1 if $attrs->{$name} =~ $value_re; |
60 | } |
61 | |
62 | return undef; |
63 | } |
64 | |
65 | sub _combinator { |
66 | my ($selectors, $current, $tree, $pos) = @_; |
67 | |
68 | # Selector |
69 | return undef unless my $c = $selectors->[$pos]; |
70 | if (ref $c) { |
71 | return undef unless _selector($c, $current); |
72 | return 1 unless $c = $selectors->[++$pos]; |
73 | } |
74 | |
75 | # ">" (parent only) |
76 | return _ancestor($selectors, $current, $tree, 1, ++$pos) if $c eq '>'; |
77 | |
78 | # "~" (preceding siblings) |
79 | return _sibling($selectors, $current, $tree, 0, ++$pos) if $c eq '~'; |
80 | |
81 | # "+" (immediately preceding siblings) |
82 | return _sibling($selectors, $current, $tree, 1, ++$pos) if $c eq '+'; |
83 | |
84 | # " " (ancestor) |
85 | return _ancestor($selectors, $current, $tree, 0, ++$pos); |
86 | } |
87 | |
88 | sub _compile { |
89 | my $css = "$_[0]"; |
90 | $css =~ s/^\s+//; |
91 | $css =~ s/\s+$//; |
92 | |
93 | my $group = [[]]; |
94 | while (my $selectors = $group->[-1]) { |
95 | push @$selectors, [] unless @$selectors && ref $selectors->[-1]; |
96 | my $last = $selectors->[-1]; |
97 | |
98 | # Separator |
99 | if ($css =~ /\G\s*,\s*/gc) { push @$group, [] } |
100 | |
101 | # Combinator |
102 | elsif ($css =~ /\G\s*([ >+~])\s*/gc) { push @$selectors, $1 } |
103 | |
104 | # Class or ID |
105 | elsif ($css =~ /\G([.#])((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) { |
106 | my ($name, $op) = $1 eq '.' ? ('class', '~') : ('id', ''); |
107 | push @$last, ['attr', _name($name), _value($op, $2)]; |
108 | } |
109 | |
110 | # Attributes |
111 | elsif ($css =~ /\G$ATTR_RE/gco) { |
2d9f5165 |
112 | push @$last, [ |
113 | 'attr', _name($1), |
114 | _value( |
115 | defined($2) ? $2 : '', |
116 | defined($3) ? $3 : defined($4) ? $4 : $5, |
117 | $6 |
118 | ), |
119 | ]; |
9a5f1e3f |
120 | } |
121 | |
eb9737f2 |
122 | # Pseudo-class |
9a5f1e3f |
123 | elsif ($css =~ /\G:([\w\-]+)(?:\(((?:\([^)]+\)|[^)])+)\))?/gcs) { |
eb9737f2 |
124 | my ($name, $args) = (lc $1, $2); |
125 | |
126 | # ":not" (contains more selectors) |
127 | $args = _compile($args) if $name eq 'not'; |
128 | |
129 | # ":nth-*" (with An+B notation) |
130 | $args = _equation($args) if $name =~ /^nth-/; |
131 | |
132 | # ":first-*" (rewrite to ":nth-*") |
133 | ($name, $args) = ("nth-$1", [0, 1]) if $name =~ /^first-(.+)$/; |
134 | |
135 | # ":last-*" (rewrite to ":nth-*") |
136 | ($name, $args) = ("nth-$name", [-1, 1]) if $name =~ /^last-/; |
137 | |
138 | push @$last, ['pc', $name, $args]; |
9a5f1e3f |
139 | } |
140 | |
141 | # Tag |
142 | elsif ($css =~ /\G((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) { |
143 | push @$last, ['tag', _name($1)] unless $1 eq '*'; |
144 | } |
145 | |
146 | else {last} |
147 | } |
148 | |
149 | return $group; |
150 | } |
151 | |
152 | sub _empty { $_[0][0] eq 'comment' || $_[0][0] eq 'pi' } |
153 | |
154 | sub _equation { |
eb9737f2 |
155 | return [0, 0] unless my $equation = shift; |
9a5f1e3f |
156 | |
157 | # "even" |
158 | return [2, 2] if $equation =~ /^\s*even\s*$/i; |
159 | |
160 | # "odd" |
161 | return [2, 1] if $equation =~ /^\s*odd\s*$/i; |
162 | |
eb9737f2 |
163 | # "4", "+4" or "-4" |
164 | return [0, $1] if $equation =~ /^\s*((?:\+|-)?\d+)\s*$/; |
165 | |
166 | # "n", "4n", "+4n", "-4n", "n+1", "4n-1", "+4n-1" (and other variations) |
167 | return [0, 0] |
168 | unless $equation =~ /^\s*((?:\+|-)?(?:\d+)?)?n\s*((?:\+|-)\s*\d+)?\s*$/i; |
4b5e2513 |
169 | return [$1 eq '-' ? -1 : !length $1 ? 1 : $1, join('', split(' ', $2 || 0))]; |
9a5f1e3f |
170 | } |
171 | |
172 | sub _match { |
173 | my ($group, $current, $tree) = @_; |
174 | _combinator([reverse @$_], $current, $tree, 0) and return 1 for @$group; |
175 | return undef; |
176 | } |
177 | |
178 | sub _name {qr/(?:^|:)\Q@{[_unescape(shift)]}\E$/} |
179 | |
180 | sub _pc { |
181 | my ($class, $args, $current) = @_; |
182 | |
eb9737f2 |
183 | # ":checked" |
184 | return exists $current->[2]{checked} || exists $current->[2]{selected} |
185 | if $class eq 'checked'; |
9a5f1e3f |
186 | |
187 | # ":not" |
188 | return !_match($args, $current, $current) if $class eq 'not'; |
189 | |
eb9737f2 |
190 | # ":empty" |
191 | return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty'; |
9a5f1e3f |
192 | |
eb9737f2 |
193 | # ":root" |
194 | return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root'; |
9a5f1e3f |
195 | |
eb9737f2 |
196 | # ":nth-child", ":nth-last-child", ":nth-of-type" or ":nth-last-of-type" |
197 | if (ref $args) { |
9a5f1e3f |
198 | my $type = $class =~ /of-type$/ ? $current->[1] : undef; |
199 | my @siblings = @{_siblings($current, $type)}; |
9a5f1e3f |
200 | @siblings = reverse @siblings if $class =~ /^nth-last/; |
201 | |
202 | for my $i (0 .. $#siblings) { |
203 | next if (my $result = $args->[0] * $i + $args->[1]) < 1; |
204 | last unless my $sibling = $siblings[$result - 1]; |
205 | return 1 if $sibling eq $current; |
206 | } |
207 | } |
208 | |
eb9737f2 |
209 | # ":only-child" or ":only-of-type" |
210 | elsif ($class eq 'only-child' || $class eq 'only-of-type') { |
211 | my $type = $class eq 'only-of-type' ? $current->[1] : undef; |
212 | $_ ne $current and return undef for @{_siblings($current, $type)}; |
9a5f1e3f |
213 | return 1; |
214 | } |
215 | |
216 | return undef; |
217 | } |
218 | |
219 | sub _select { |
220 | my ($one, $tree, $group) = @_; |
221 | |
222 | my @results; |
223 | my @queue = @$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree]; |
224 | while (my $current = shift @queue) { |
225 | next unless $current->[0] eq 'tag'; |
226 | |
227 | unshift @queue, @$current[4 .. $#$current]; |
228 | next unless _match($group, $current, $tree); |
229 | $one ? return $current : push @results, $current; |
230 | } |
231 | |
232 | return $one ? undef : \@results; |
233 | } |
234 | |
235 | sub _selector { |
236 | my ($selector, $current) = @_; |
237 | |
238 | for my $s (@$selector) { |
239 | my $type = $s->[0]; |
240 | |
241 | # Tag |
242 | if ($type eq 'tag') { return undef unless $current->[1] =~ $s->[1] } |
243 | |
244 | # Attribute |
245 | elsif ($type eq 'attr') { return undef unless _attr(@$s[1, 2], $current) } |
246 | |
247 | # Pseudo-class |
248 | elsif ($type eq 'pc') { return undef unless _pc(@$s[1, 2], $current) } |
249 | } |
250 | |
251 | return 1; |
252 | } |
253 | |
254 | sub _sibling { |
255 | my ($selectors, $current, $tree, $immediate, $pos) = @_; |
256 | |
257 | my $found; |
258 | for my $sibling (@{_siblings($current)}) { |
259 | return $found if $sibling eq $current; |
260 | |
261 | # "+" (immediately preceding sibling) |
262 | if ($immediate) { $found = _combinator($selectors, $sibling, $tree, $pos) } |
263 | |
264 | # "~" (preceding sibling) |
265 | else { return 1 if _combinator($selectors, $sibling, $tree, $pos) } |
266 | } |
267 | |
268 | return undef; |
269 | } |
270 | |
271 | sub _siblings { |
272 | my ($current, $type) = @_; |
273 | |
274 | my $parent = $current->[3]; |
275 | my @siblings = grep { $_->[0] eq 'tag' } |
276 | @$parent[($parent->[0] eq 'root' ? 1 : 4) .. $#$parent]; |
277 | @siblings = grep { $type eq $_->[1] } @siblings if defined $type; |
278 | |
279 | return \@siblings; |
280 | } |
281 | |
282 | sub _unescape { |
283 | my $value = shift; |
284 | |
285 | # Remove escaped newlines |
286 | $value =~ s/\\\n//g; |
287 | |
288 | # Unescape Unicode characters |
289 | $value =~ s/\\([0-9a-fA-F]{1,6})\s?/pack 'U', hex $1/ge; |
290 | |
291 | # Remove backslash |
292 | $value =~ s/\\//g; |
293 | |
294 | return $value; |
295 | } |
296 | |
297 | sub _value { |
298 | my ($op, $value, $insensitive) = @_; |
299 | return undef unless defined $value; |
300 | $value = ($insensitive ? '(?i)' : '') . quotemeta _unescape($value); |
301 | |
302 | # "~=" (word) |
303 | return qr/(?:^|\s+)$value(?:\s+|$)/ if $op eq '~'; |
304 | |
305 | # "*=" (contains) |
306 | return qr/$value/ if $op eq '*'; |
307 | |
308 | # "^=" (begins with) |
309 | return qr/^$value/ if $op eq '^'; |
310 | |
311 | # "$=" (ends with) |
312 | return qr/$value$/ if $op eq '$'; |
313 | |
314 | # Everything else |
315 | return qr/^$value$/; |
316 | } |
317 | |
318 | 1; |
319 | |
320 | =for Pod::Coverage *EVERYTHING* |
321 | |
322 | =cut |