lib/DOM/Tiny/_CSS.pm

   1 package DOM::Tiny::_CSS;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.003';
   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) {
 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       ];
 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 '-';
 154   $num->[1] = defined($3) ? $3 : 0;
 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