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
  11 sub new { bless({}, shift) }
  12
  13 sub _raw_parse_simple_selector {
  14   for ($_[1]) { # same pos() as outside
  15
  16     # '*' - match anything
  17
  18     /\G\*/gc and
  19       return sub { 1 };
  20
  21      # 'el[attr="foo"]
  22
  23     /\G$sel_re\[$sel_re="$sel_re"\]/gc and
  24       return do {
  25         my $name = $1;
  26         my $attr = $2;
  27         my $val = $3;
  28         sub {
  29            $_[0]->{name} && $_[0]->{name} eq $name and
  30            $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} eq $val
  31         }
  32       };
  33
  34     # 'element' - match on tag name
  35
  36     /\G$sel_re/gc and
  37       return do {
  38         my $name = $1;
  39         sub { $_[0]->{name} && $_[0]->{name} eq $name }
  40       };
  41
  42     # '#id' - match on id attribute
  43
  44     /\G#$sel_re/gc and
  45       return do {
  46         my $id = $1;
  47         sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
  48       };
  49
  50     # '.class1.class2' - match on intersection of classes
  51
  52     /\G((?:\.$sel_re)+)/gc and
  53       return do {
  54         my $cls = $1; $cls =~ s/^\.//;
  55         my @cl = split(/\./, $cls);
  56         sub {
  57           $_[0]->{attrs}{class}
  58           && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
  59         }
  60       };
  61
  62     # 'el.class1' - element + class
  63
  64     /\G$sel_re\.$sel_re/gc and
  65       return do {
  66         my $cls = $1;
  67         my $name = $2;
  68         sub {
  69            $_[0]->{name} && $_[0]->{name} eq $name and
  70            $_[0]->{attrs}{class} && $_[0]->{attrs}{class} eq $cls
  71         }
  72       };
  73
  74     # 'el#id' - element + id
  75
  76     /\G$sel_re#$sel_re/gc and
  77       return do {
  78         my $id = $1;
  79         my $name = $2;
  80         sub {
  81            $_[0]->{name} && $_[0]->{name} eq $name and
  82            $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id
  83         }
  84       };
  85
  86     confess "Couldn't parse $_ as starting with simple selector";
  87   }
  88 }
  89
  90 sub parse_selector {
  91   my $self = $_[0];
  92   my $sel = $_[1]; # my pos() only please
  93   die "No selector provided" unless $sel;
  94   local *_;
  95   for ($sel) {
  96     my @sub;
  97     PARSE: { do {
  98       push(@sub, $self->_raw_parse_simple_selector($_));
  99       last PARSE if (pos == length);
 100       /\G\s*,\s*/gc or confess "Selectors not comma separated";
 101     } until (pos == length) };
 102     return $sub[0] if (@sub == 1);
 103     return sub {
 104       foreach my $inner (@sub) {
 105         if (my $r = $inner->(@_)) { return $r }
 106       }
 107     };
 108   }
 109 }
 110
 111
 112 1;