lib/DOM/Tiny/_CSS.pm

   1 package DOM::Tiny::_CSS;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.004';
   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
 123     elsif ($css =~ /\G:([\w\-]+)(?:\(((?:\([^)]+\)|[^)])+)\))?/gcs) {
 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];
 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 {
 155   return [0, 0] unless my $equation = shift;
 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
 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;
 169   return [$1 eq '-' ? -1 : !length $1 ? 1 : $1, join('', split(' ', $2 || 0))];
 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
 183   # ":checked"
 184   return exists $current->[2]{checked} || exists $current->[2]{selected}
 185     if $class eq 'checked';
 186
 187   # ":not"
 188   return !_match($args, $current, $current) if $class eq 'not';
 189
 190   # ":empty"
 191   return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty';
 192
 193   # ":root"
 194   return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root';
 195
 196   # ":nth-child", ":nth-last-child", ":nth-of-type" or ":nth-last-of-type"
 197   if (ref $args) {
 198     my $type = $class =~ /of-type$/ ? $current->[1] : undef;
 199     my @siblings = @{_siblings($current, $type)};
 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
 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)};
 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