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