lib/HTML/Zoom/SelectorParser.pm

   1 package HTML::Zoom::SelectorParser;
   2
   3 use strictures 1;
   4 use base qw(HTML::Zoom::SubObject);
   5 use Carp qw(confess);
   6
   7 my $sel_char = '-\w_';
   8 my $sel_meta_char = q-!"#$%&'()*+,./:;<=>?@[\]^`{|}~-;
   9 my $sel_item = qr/(?:(?:\\[\Q$sel_meta_char\E])|[$sel_char])/;
  10 my $sel_re = qr/($sel_item+)/;
  11 my $match_value_re = qr/"?($sel_item*)"?/;
  12
  13
  14 sub new { bless({}, shift) }
  15
  16 sub _raw_parse_simple_selector {
  17   for ($_[1]) { # same pos() as outside
  18
  19     # '*' - match anything
  20
  21     /\G\*/gc and
  22       return sub { 1 };
  23
  24     # 'element' - match on tag name
  25
  26     /\G$sel_re/gc and
  27       return do {
  28         my $name = $_[0]->_unescape($1);
  29         sub { $_[0]->{name} && $_[0]->{name} eq $name }
  30       };
  31
  32     # '#id' - match on id attribute
  33
  34     /\G#$sel_re/gc and
  35       return do {
  36         my $id = $_[0]->_unescape($1);
  37         sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
  38       };
  39
  40     # '.class1.class2' - match on intersection of classes
  41
  42     /\G((?:\.$sel_re)+)/gc and
  43       return do {
  44         my $cls = $1; $cls =~ s/^\.//;
  45         my @cl = map $_[0]->_unescape($_), split(/(?<!\\)\./, $cls);
  46         sub {
  47           $_[0]->{attrs}{class}
  48           && !grep $_[0]->{attrs}{class} !~ /(^|\s+)\Q$_\E($|\s+)/, @cl
  49         }
  50       };
  51
  52     # '[attr^=foo]' - match attribute with ^ anchored regex
  53     /\G\[$sel_re\^=$match_value_re\]/gc and
  54       return do {
  55         my $attribute = $_[0]->_unescape($1);
  56         my $value = $_[0]->_unescape($2);
  57         sub {
  58           exists $_[0]->{attrs}{$attribute}
  59           && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
  60         }
  61       };
  62
  63     # '[attr$=foo]' - match attribute with $ anchored regex
  64     /\G\[$sel_re\$=$match_value_re\]/gc and
  65       return do {
  66         my $attribute = $_[0]->_unescape($1);
  67         my $value = $_[0]->_unescape($2);
  68         sub {
  69           exists $_[0]->{attrs}{$attribute}
  70           && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
  71         }
  72       };
  73
  74     # '[attr*=foo] - match attribute with regex:
  75     /\G\[$sel_re\*=$match_value_re\]/gc and
  76       return do {
  77         my $attribute = $_[0]->_unescape($1);
  78         my $value = $_[0]->_unescape($2);
  79         sub {
  80           exists $_[0]->{attrs}{$attribute}
  81           && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/;
  82         }
  83       };
  84
  85     # '[attr~=bar]' - match attribute contains word
  86     /\G\[$sel_re~=$match_value_re\]/gc and
  87       return do {
  88         my $attribute = $_[0]->_unescape($1);
  89         my $value = $_[0]->_unescape($2);
  90         sub {
  91           exists $_[0]->{attrs}{$attribute}
  92           && $_[0]->{attrs}{$attribute} =~ qr/\b\Q$value\E\b/;
  93         }
  94       };
  95
  96     # '[attr!=bar]' - match attribute contains prefix (for language matches)
  97     /\G\[$sel_re\|=$match_value_re\]/gc and
  98       return do {
  99         my $attribute = $_[0]->_unescape($1);
 100         my $value = $_[0]->_unescape($2);
 101         sub {
 102           exists $_[0]->{attrs}{$attribute}
 103           && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E(?:-|$)/;
 104         }
 105       };
 106
 107     # '[attr=bar]' - match attributes
 108     /\G\[$sel_re=$match_value_re\]/gc and
 109       return do {
 110         my $attribute = $_[0]->_unescape($1);
 111         my $value = $_[0]->_unescape($2);
 112         sub {
 113           exists $_[0]->{attrs}{$attribute}
 114           && $_[0]->{attrs}{$attribute} eq $value;
 115         }
 116       };
 117
 118     # '[attr!=bar]' - attributes doesn't match
 119     /\G\[$sel_re!=$match_value_re\]/gc and
 120       return do {
 121         my $attribute = $_[0]->_unescape($1);
 122         my $value = $_[0]->_unescape($2);
 123         sub {
 124           ! (exists $_[0]->{attrs}{$attribute}
 125           && $_[0]->{attrs}{$attribute} eq $value);
 126         }
 127       };
 128
 129     # '[attr]' - match attribute being present:
 130     /\G\[$sel_re\]/gc and
 131       return do {
 132         my $attribute = $_[0]->_unescape($1);
 133         sub {
 134           exists $_[0]->{attrs}{$attribute};
 135         }
 136     };
 137
 138     # none of the above matched, try catching some obvious errors:
 139
 140     # indicate unmatched square bracket:
 141     /\G\[[^\]]*/gc and $_[0]->_blam('Unmatched [');
 142   }
 143 }
 144
 145 sub parse_selector {
 146   my $self = $_[0];
 147   my $sel = $_[1]; # my pos() only please
 148   die "No selector provided" unless $sel;
 149   local *_;
 150   for ($sel) {
 151     my @sub;
 152     PARSE: { do {
 153
 154       my @this_chain;
 155
 156       # slurp selectors until we find something else:
 157       while( my $sel = $self->_raw_parse_simple_selector($_) ){
 158         push @this_chain, $sel;
 159       }
 160
 161       if( @this_chain == 1 )
 162       {
 163         push @sub, @this_chain;
 164       }
 165       else{
 166         # make a compound match closure of everything
 167         # in this chain of selectors:
 168         push @sub, sub{
 169           my $r;
 170           for my $inner ( @this_chain ){
 171             if( ! ($r = $inner->( @_ )) ){
 172               return $r;
 173             }
 174           }
 175           return $r;
 176         }
 177       }
 178
 179       # now we're at the end or a delimiter:
 180       last PARSE if( pos == length );
 181       /\G\s*,\s*/gc or do {
 182         /\G(.*)/;
 183         $self->_blam( "Selectors not comma separated." );
 184       }
 185
 186      } until (pos == length) };
 187     return $sub[0] if (@sub == 1);
 188     return sub {
 189       foreach my $inner (@sub) {
 190         if (my $r = $inner->(@_)) { return $r }
 191       }
 192     };
 193   }
 194 }
 195
 196 sub _unescape {
 197     my ($self, $escaped) = @_;
 198     (my $unescaped = $escaped) =~ s/\\([\Q$sel_meta_char\E])/$1/g;
 199     return $unescaped;
 200 }
 201
 202 sub _blam {
 203   my ($self, $error) = @_;
 204   my $hat = (' ' x (pos||0)).'^';
 205   die "Error parsing dispatch specification: ${error}\n
 206 ${_}
 207 ${hat} here\n";
 208 }
 209
 210 1;