lib/DOM/Tiny/_CSS.pm

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