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         $_[0]->{attrs}{$attribute}
  57         && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
  58       };
  59
  60     # '[attr$=foo]' - match attribute with $ anchored regex
  61     /\G\[$sel_re\$=$match_value_re\]/gc and
  62       return do{
  63         my $attribute = $1;
  64         my $value = $2;
  65         $_[0]->{attrs}{$attribute}
  66         && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
  67       };
  68
  69     # '[attr*=foo] - match attribute with regex:
  70     /\G\[$sel_re\*=$match_value_re\]/gc and
  71       return do{
  72         my $attribute = $1;
  73         my $value = $2;
  74         $_[0]->{attrs}{$attribute}
  75         && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
  76       };
  77
  78     # '[attr=bar]' - match attributes
  79     /\G\[$sel_re=$match_value_re\]/gc and
  80       return do {
  81         my $attribute = $1;
  82         my $value = $2;
  83         sub{
  84           $_[0]->{attrs}{$attribute}
  85           && $_[0]->{attrs}{$attribute} eq $value;
  86         }
  87       };
  88
  89     # '[attr] - match attribute being present:
  90     /\G\[$sel_re\]/gc and
  91       return do {
  92         my $attribute = $1;
  93         $_[0]->{attrs}{$attribute};
  94       }
  95   }
  96 }
  97
  98 sub parse_selector {
  99   my $self = $_[0];
 100   my $sel = $_[1]; # my pos() only please
 101   die "No selector provided" unless $sel;
 102   local *_;
 103   for ($sel) {
 104     my @sub;
 105     PARSE: { do {
 106
 107       my @this_chain;
 108
 109       # slurp selectors until we find something else:
 110       while( my $sel = $self->_raw_parse_simple_selector($_) ){
 111         push @this_chain, $sel;
 112       }
 113
 114       if( @this_chain == 1 )
 115       {
 116         push @sub, @this_chain;
 117       }
 118       else{
 119         # make a compound match closure of everything
 120         # in this chain of selectors:
 121         push @sub, sub{
 122           my $r;
 123           for my $inner ( @this_chain ){
 124             if( ! ($r = $inner->( @_ )) ){
 125               return $r;
 126             }
 127           }
 128           return $r;
 129         }
 130       }
 131
 132       # now we're at the end or a delimiter:
 133       last PARSE if( pos == length );
 134       /\G\s*,\s*/gc or do {
 135         /\G(.*)/;
 136         $self->_blam( "Selectors not comma separated." );
 137       }
 138
 139      } until (pos == length) };
 140     return $sub[0] if (@sub == 1);
 141     return sub {
 142       foreach my $inner (@sub) {
 143         if (my $r = $inner->(@_)) { return $r }
 144       }
 145     };
 146   }
 147 }
 148
 149
 150 sub _blam {
 151   my ($self, $error) = @_;
 152   my $hat = (' ' x (pos||0)).'^';
 153   die "Error parsing dispatch specification: ${error}\n
 154 ${_}
 155 ${hat} here\n";
 156 }
 157
 158 1;