1 package DOM::Tiny::_CSS;
6 our $VERSION = '0.002';
8 my $ESCAPE_RE = qr/\\[^0-9a-fA-F]|\\[0-9a-fA-F]{1,6}/;
11 ((?:$ESCAPE_RE|[\w\-])+) # Key
14 (?:"((?:\\"|[^"])*)"|'((?:\\'|[^'])*)'|([^\]]+?)) # Value
15 (?:\s+(i))? # Case-sensitivity
22 bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
27 return $self->{tree} unless @_;
28 $self->{tree} = shift;
33 my $tree = shift->tree;
34 return $tree->[0] ne 'tag' ? undef : _match(_compile(shift), $tree, $tree);
37 sub select { _select(0, shift->tree, _compile(@_)) }
38 sub select_one { _select(1, shift->tree, _compile(@_)) }
41 my ($selectors, $current, $tree, $one, $pos) = @_;
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);
53 my ($name_re, $value_re, $current) = @_;
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;
66 my ($selectors, $current, $tree, $pos) = @_;
69 return undef unless my $c = $selectors->[$pos];
71 return undef unless _selector($c, $current);
72 return 1 unless $c = $selectors->[++$pos];
76 return _ancestor($selectors, $current, $tree, 1, ++$pos) if $c eq '>';
78 # "~" (preceding siblings)
79 return _sibling($selectors, $current, $tree, 0, ++$pos) if $c eq '~';
81 # "+" (immediately preceding siblings)
82 return _sibling($selectors, $current, $tree, 1, ++$pos) if $c eq '+';
85 return _ancestor($selectors, $current, $tree, 0, ++$pos);
94 while (my $selectors = $group->[-1]) {
95 push @$selectors, [] unless @$selectors && ref $selectors->[-1];
96 my $last = $selectors->[-1];
99 if ($css =~ /\G\s*,\s*/gc) { push @$group, [] }
102 elsif ($css =~ /\G\s*([ >+~])\s*/gc) { push @$selectors, $1 }
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)];
111 elsif ($css =~ /\G$ATTR_RE/gco) {
112 push @$last, ['attr', _name($1), _value($2 // '', $3 // $4 // $5, $6)];
115 # Pseudo-class (":not" contains more selectors)
116 elsif ($css =~ /\G:([\w\-]+)(?:\(((?:\([^)]+\)|[^)])+)\))?/gcs) {
117 push @$last, ['pc', lc $1, $1 eq 'not' ? _compile($2) : _equation($2)];
121 elsif ($css =~ /\G((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) {
122 push @$last, ['tag', _name($1)] unless $1 eq '*';
131 sub _empty { $_[0][0] eq 'comment' || $_[0][0] eq 'pi' }
134 return [] unless my $equation = shift;
137 return [2, 2] if $equation =~ /^\s*even\s*$/i;
140 return [2, 1] if $equation =~ /^\s*odd\s*$/i;
144 return $num if $equation !~ /(?:(-?(?:\d+)?)?(n))?\s*\+?\s*(-?\s*\d+)?\s*$/i;
145 $num->[0] = defined($1) && $1 ne '' ? $1 : $2 ? 1 : 0;
146 $num->[0] = -1 if $num->[0] eq '-';
148 $num->[1] =~ s/\s+//g;
153 my ($group, $current, $tree) = @_;
154 _combinator([reverse @$_], $current, $tree, 0) and return 1 for @$group;
158 sub _name {qr/(?:^|:)\Q@{[_unescape(shift)]}\E$/}
161 my ($class, $args, $current) = @_;
164 return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty';
167 return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root';
170 return !_match($args, $current, $current) if $class eq 'not';
173 return exists $current->[2]{checked} || exists $current->[2]{selected}
174 if $class eq 'checked';
176 # ":first-*" or ":last-*" (rewrite with equation)
177 ($class, $args) = $1 ? ("nth-$class", [0, 1]) : ("nth-last-$class", [-1, 1])
178 if $class =~ s/^(?:(first)|last)-//;
181 if ($class =~ /^nth-/) {
182 my $type = $class =~ /of-type$/ ? $current->[1] : undef;
183 my @siblings = @{_siblings($current, $type)};
186 @siblings = reverse @siblings if $class =~ /^nth-last/;
188 for my $i (0 .. $#siblings) {
189 next if (my $result = $args->[0] * $i + $args->[1]) < 1;
190 last unless my $sibling = $siblings[$result - 1];
191 return 1 if $sibling eq $current;
196 elsif ($class =~ /^only-(?:child|(of-type))$/) {
197 $_ ne $current and return undef
198 for @{_siblings($current, $1 ? $current->[1] : undef)};
206 my ($one, $tree, $group) = @_;
209 my @queue = @$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree];
210 while (my $current = shift @queue) {
211 next unless $current->[0] eq 'tag';
213 unshift @queue, @$current[4 .. $#$current];
214 next unless _match($group, $current, $tree);
215 $one ? return $current : push @results, $current;
218 return $one ? undef : \@results;
222 my ($selector, $current) = @_;
224 for my $s (@$selector) {
228 if ($type eq 'tag') { return undef unless $current->[1] =~ $s->[1] }
231 elsif ($type eq 'attr') { return undef unless _attr(@$s[1, 2], $current) }
234 elsif ($type eq 'pc') { return undef unless _pc(@$s[1, 2], $current) }
241 my ($selectors, $current, $tree, $immediate, $pos) = @_;
244 for my $sibling (@{_siblings($current)}) {
245 return $found if $sibling eq $current;
247 # "+" (immediately preceding sibling)
248 if ($immediate) { $found = _combinator($selectors, $sibling, $tree, $pos) }
250 # "~" (preceding sibling)
251 else { return 1 if _combinator($selectors, $sibling, $tree, $pos) }
258 my ($current, $type) = @_;
260 my $parent = $current->[3];
261 my @siblings = grep { $_->[0] eq 'tag' }
262 @$parent[($parent->[0] eq 'root' ? 1 : 4) .. $#$parent];
263 @siblings = grep { $type eq $_->[1] } @siblings if defined $type;
271 # Remove escaped newlines
274 # Unescape Unicode characters
275 $value =~ s/\\([0-9a-fA-F]{1,6})\s?/pack 'U', hex $1/ge;
284 my ($op, $value, $insensitive) = @_;
285 return undef unless defined $value;
286 $value = ($insensitive ? '(?i)' : '') . quotemeta _unescape($value);
289 return qr/(?:^|\s+)$value(?:\s+|$)/ if $op eq '~';
292 return qr/$value/ if $op eq '*';
295 return qr/^$value/ if $op eq '^';
298 return qr/$value$/ if $op eq '$';
306 =for Pod::Coverage *EVERYTHING*