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 }
 105
 106 sub parse_selector {
 107   my $self = $_[0];
 108   my $sel = $_[1]; # my pos() only please
 109   die "No selector provided" unless $sel;
 110   local *_;
 111   for ($sel) {
 112     my @sub;
 113     PARSE: { do {
 114
 115       my @this_chain;
 116
 117       # slurp selectors until we find something else:
 118       while( my $sel = $self->_raw_parse_simple_selector($_) ){
 119         push @this_chain, $sel;
 120       }
 121
 122       if( @this_chain == 1 )
 123       {
 124         push @sub, @this_chain;
 125       }
 126       else{
 127         # make a compound match closure of everything
 128         # in this chain of selectors:
 129         push @sub, sub{
 130           my $r;
 131           for my $inner ( @this_chain ){
 132             if( ! ($r = $inner->( @_ )) ){
 133               return $r;
 134             }
 135           }
 136           return $r;
 137         }
 138       }
 139
 140       # now we're at the end or a delimiter:
 141       last PARSE if( pos == length );
 142       /\G\s*,\s*/gc or do {
 143         /\G(.*)/;
 144         $self->_blam( "Selectors not comma separated." );
 145       }
 146
 147      } until (pos == length) };
 148     return $sub[0] if (@sub == 1);
 149     return sub {
 150       foreach my $inner (@sub) {
 151         if (my $r = $inner->(@_)) { return $r }
 152       }
 153     };
 154   }
 155 }
 156
 157
 158 sub _blam {
 159   my ($self, $error) = @_;
 160   my $hat = (' ' x (pos||0)).'^';
 161   die "Error parsing dispatch specification: ${error}\n
 162 ${_}
 163 ${hat} here\n";
 164 }
 165
 166 1;