lib/HTML/Zoom/SelectorParser.pm

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