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 attributes
  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           && $_[0]->{attrs}{$attribute} eq $value;
  92         }
  93       };
  94
  95     # '[attr] - match attribute being present:
  96     /\G\[$sel_re\]/gc and
  97       return do {
  98         my $attribute = $1;
  99         sub {
 100           exists $_[0]->{attrs}{$attribute};
 101         }
 102     };
 103
 104     # none of the above matched, try catching some obvious errors:
 105
 106     # indicate unmatched square bracket:
 107     /\G\[[^\]]*/gc and $_[0]->_blam('Unmatched [');
 108   }
 109 }
 110
 111 sub parse_selector {
 112   my $self = $_[0];
 113   my $sel = $_[1]; # my pos() only please
 114   die "No selector provided" unless $sel;
 115   local *_;
 116   for ($sel) {
 117     my @sub;
 118     PARSE: { do {
 119
 120       my @this_chain;
 121
 122       # slurp selectors until we find something else:
 123       while( my $sel = $self->_raw_parse_simple_selector($_) ){
 124         push @this_chain, $sel;
 125       }
 126
 127       if( @this_chain == 1 )
 128       {
 129         push @sub, @this_chain;
 130       }
 131       else{
 132         # make a compound match closure of everything
 133         # in this chain of selectors:
 134         push @sub, sub{
 135           my $r;
 136           for my $inner ( @this_chain ){
 137             if( ! ($r = $inner->( @_ )) ){
 138               return $r;
 139             }
 140           }
 141           return $r;
 142         }
 143       }
 144
 145       # now we're at the end or a delimiter:
 146       last PARSE if( pos == length );
 147       /\G\s*,\s*/gc or do {
 148         /\G(.*)/;
 149         $self->_blam( "Selectors not comma separated." );
 150       }
 151
 152      } until (pos == length) };
 153     return $sub[0] if (@sub == 1);
 154     return sub {
 155       foreach my $inner (@sub) {
 156         if (my $r = $inner->(@_)) { return $r }
 157       }
 158     };
 159   }
 160 }
 161
 162
 163 sub _blam {
 164   my ($self, $error) = @_;
 165   my $hat = (' ' x (pos||0)).'^';
 166   die "Error parsing dispatch specification: ${error}\n
 167 ${_}
 168 ${hat} here\n";
 169 }
 170
 171 1;