Commit | Line | Data |
9a5f1e3f |
1 | package DOM::Tiny::_CSS; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
8398aa8a |
6 | our $VERSION = '0.002'; |
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 | |
122 | # Pseudo-class (":not" contains more selectors) |
123 | elsif ($css =~ /\G:([\w\-]+)(?:\(((?:\([^)]+\)|[^)])+)\))?/gcs) { |
124 | push @$last, ['pc', lc $1, $1 eq 'not' ? _compile($2) : _equation($2)]; |
125 | } |
126 | |
127 | # Tag |
128 | elsif ($css =~ /\G((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) { |
129 | push @$last, ['tag', _name($1)] unless $1 eq '*'; |
130 | } |
131 | |
132 | else {last} |
133 | } |
134 | |
135 | return $group; |
136 | } |
137 | |
138 | sub _empty { $_[0][0] eq 'comment' || $_[0][0] eq 'pi' } |
139 | |
140 | sub _equation { |
141 | return [] unless my $equation = shift; |
142 | |
143 | # "even" |
144 | return [2, 2] if $equation =~ /^\s*even\s*$/i; |
145 | |
146 | # "odd" |
147 | return [2, 1] if $equation =~ /^\s*odd\s*$/i; |
148 | |
149 | # Equation |
150 | my $num = [1, 1]; |
151 | return $num if $equation !~ /(?:(-?(?:\d+)?)?(n))?\s*\+?\s*(-?\s*\d+)?\s*$/i; |
152 | $num->[0] = defined($1) && $1 ne '' ? $1 : $2 ? 1 : 0; |
153 | $num->[0] = -1 if $num->[0] eq '-'; |
2d9f5165 |
154 | $num->[1] = defined($3) ? $3 : 0; |
9a5f1e3f |
155 | $num->[1] =~ s/\s+//g; |
156 | return $num; |
157 | } |
158 | |
159 | sub _match { |
160 | my ($group, $current, $tree) = @_; |
161 | _combinator([reverse @$_], $current, $tree, 0) and return 1 for @$group; |
162 | return undef; |
163 | } |
164 | |
165 | sub _name {qr/(?:^|:)\Q@{[_unescape(shift)]}\E$/} |
166 | |
167 | sub _pc { |
168 | my ($class, $args, $current) = @_; |
169 | |
170 | # ":empty" |
171 | return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty'; |
172 | |
173 | # ":root" |
174 | return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root'; |
175 | |
176 | # ":not" |
177 | return !_match($args, $current, $current) if $class eq 'not'; |
178 | |
179 | # ":checked" |
180 | return exists $current->[2]{checked} || exists $current->[2]{selected} |
181 | if $class eq 'checked'; |
182 | |
183 | # ":first-*" or ":last-*" (rewrite with equation) |
184 | ($class, $args) = $1 ? ("nth-$class", [0, 1]) : ("nth-last-$class", [-1, 1]) |
185 | if $class =~ s/^(?:(first)|last)-//; |
186 | |
187 | # ":nth-*" |
188 | if ($class =~ /^nth-/) { |
189 | my $type = $class =~ /of-type$/ ? $current->[1] : undef; |
190 | my @siblings = @{_siblings($current, $type)}; |
191 | |
192 | # ":nth-last-*" |
193 | @siblings = reverse @siblings if $class =~ /^nth-last/; |
194 | |
195 | for my $i (0 .. $#siblings) { |
196 | next if (my $result = $args->[0] * $i + $args->[1]) < 1; |
197 | last unless my $sibling = $siblings[$result - 1]; |
198 | return 1 if $sibling eq $current; |
199 | } |
200 | } |
201 | |
202 | # ":only-*" |
203 | elsif ($class =~ /^only-(?:child|(of-type))$/) { |
204 | $_ ne $current and return undef |
205 | for @{_siblings($current, $1 ? $current->[1] : undef)}; |
206 | return 1; |
207 | } |
208 | |
209 | return undef; |
210 | } |
211 | |
212 | sub _select { |
213 | my ($one, $tree, $group) = @_; |
214 | |
215 | my @results; |
216 | my @queue = @$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree]; |
217 | while (my $current = shift @queue) { |
218 | next unless $current->[0] eq 'tag'; |
219 | |
220 | unshift @queue, @$current[4 .. $#$current]; |
221 | next unless _match($group, $current, $tree); |
222 | $one ? return $current : push @results, $current; |
223 | } |
224 | |
225 | return $one ? undef : \@results; |
226 | } |
227 | |
228 | sub _selector { |
229 | my ($selector, $current) = @_; |
230 | |
231 | for my $s (@$selector) { |
232 | my $type = $s->[0]; |
233 | |
234 | # Tag |
235 | if ($type eq 'tag') { return undef unless $current->[1] =~ $s->[1] } |
236 | |
237 | # Attribute |
238 | elsif ($type eq 'attr') { return undef unless _attr(@$s[1, 2], $current) } |
239 | |
240 | # Pseudo-class |
241 | elsif ($type eq 'pc') { return undef unless _pc(@$s[1, 2], $current) } |
242 | } |
243 | |
244 | return 1; |
245 | } |
246 | |
247 | sub _sibling { |
248 | my ($selectors, $current, $tree, $immediate, $pos) = @_; |
249 | |
250 | my $found; |
251 | for my $sibling (@{_siblings($current)}) { |
252 | return $found if $sibling eq $current; |
253 | |
254 | # "+" (immediately preceding sibling) |
255 | if ($immediate) { $found = _combinator($selectors, $sibling, $tree, $pos) } |
256 | |
257 | # "~" (preceding sibling) |
258 | else { return 1 if _combinator($selectors, $sibling, $tree, $pos) } |
259 | } |
260 | |
261 | return undef; |
262 | } |
263 | |
264 | sub _siblings { |
265 | my ($current, $type) = @_; |
266 | |
267 | my $parent = $current->[3]; |
268 | my @siblings = grep { $_->[0] eq 'tag' } |
269 | @$parent[($parent->[0] eq 'root' ? 1 : 4) .. $#$parent]; |
270 | @siblings = grep { $type eq $_->[1] } @siblings if defined $type; |
271 | |
272 | return \@siblings; |
273 | } |
274 | |
275 | sub _unescape { |
276 | my $value = shift; |
277 | |
278 | # Remove escaped newlines |
279 | $value =~ s/\\\n//g; |
280 | |
281 | # Unescape Unicode characters |
282 | $value =~ s/\\([0-9a-fA-F]{1,6})\s?/pack 'U', hex $1/ge; |
283 | |
284 | # Remove backslash |
285 | $value =~ s/\\//g; |
286 | |
287 | return $value; |
288 | } |
289 | |
290 | sub _value { |
291 | my ($op, $value, $insensitive) = @_; |
292 | return undef unless defined $value; |
293 | $value = ($insensitive ? '(?i)' : '') . quotemeta _unescape($value); |
294 | |
295 | # "~=" (word) |
296 | return qr/(?:^|\s+)$value(?:\s+|$)/ if $op eq '~'; |
297 | |
298 | # "*=" (contains) |
299 | return qr/$value/ if $op eq '*'; |
300 | |
301 | # "^=" (begins with) |
302 | return qr/^$value/ if $op eq '^'; |
303 | |
304 | # "$=" (ends with) |
305 | return qr/$value$/ if $op eq '$'; |
306 | |
307 | # Everything else |
308 | return qr/^$value$/; |
309 | } |
310 | |
311 | 1; |
312 | |
313 | =for Pod::Coverage *EVERYTHING* |
314 | |
315 | =cut |