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 my $match_attr_on_regex = sub {
  14    my ($self, $name, $attr, $regex) = @_;
  15
  16    sub {
  17       $_[0]->{name} && $_[0]->{name} eq $name and
  18       $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ $regex
  19    }
  20 };
  21
  22 my $match_attr_on_eq = sub {
  23    my ($self, $name, $attr, $val) = @_;
  24
  25    sub {
  26       $_[0]->{name} && $_[0]->{name} eq $name and
  27       $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} eq $val
  28    }
  29 };
  30
  31 sub _raw_parse_simple_selector {
  32   for ($_[1]) { # same pos() as outside
  33
  34     # '*' - match anything
  35
  36     /\G\*/gc and
  37       return sub { 1 };
  38
  39      # 'el[attr~="foo"]
  40
  41     /\G$sel_re\[$sel_re~="$sel_re"\]/gc and
  42       return do {
  43         my $name = $1;
  44         my $attr = $2;
  45         my $val = $3;
  46         sub {
  47           if (
  48             $_[0]->{name} && $_[0]->{name} eq $name and
  49             $_[0]->{attrs}{$attr}
  50           ) {
  51             my %vals = map { $_ => 1 } split /\s+/, $_[0]->{attrs}{$attr};
  52             return $vals{$val}
  53           }
  54           return undef
  55         }
  56       };
  57
  58      # 'el[attr^="foo"]
  59
  60     /\G$sel_re\[$sel_re\^="$sel_re"\]/gc and
  61       return do { $_[0]->$match_attr_on_regex($1, $2, qr/^\Q$3\E/) };
  62
  63      # 'el[attr$="foo"]
  64
  65     /\G$sel_re\[$sel_re\$="$sel_re"\]/gc and
  66       return do { $_[0]->$match_attr_on_regex($1, $2, qr/\Q$3\E$/) };
  67
  68      # 'el[attr*="foo"]
  69
  70     /\G$sel_re\[$sel_re\*="$sel_re"\]/gc and
  71       return do { $_[0]->$match_attr_on_regex($1, $2, qr/\Q$3\E/) };
  72
  73      # 'el[attr="foo"]
  74
  75     /\G$sel_re\[$sel_re="$sel_re"\]/gc and
  76       return do { $_[0]->$match_attr_on_eq($1, $2, $3) };
  77
  78      # 'el[attr]
  79
  80     /\G$sel_re\[$sel_re\]/gc and
  81       return do {
  82         my $name = $1;
  83         my $attr = $2;
  84         sub {
  85            $_[0]->{name} && $_[0]->{name} eq $name && $_[0]->{attrs}{$attr}
  86         }
  87       };
  88
  89     # 'el.class1' - element + class
  90
  91     /\G$sel_re\.$sel_re/gc and
  92       return do { $_[0]->$match_attr_on_eq($1, 'class', $2) };
  93
  94     # 'el#id' - element + id
  95     /\G$sel_re#$sel_re/gc and
  96       return do { $_[0]->$match_attr_on_eq($1, 'id', $2) };
  97
  98     # 'element' - match on tag name
  99
 100     /\G$sel_re/gc and
 101       return do {
 102         my $name = $1;
 103         sub { $_[0]->{name} && $_[0]->{name} eq $name }
 104       };
 105
 106     # '#id' - match on id attribute
 107
 108     /\G#$sel_re/gc and
 109       return do {
 110         my $id = $1;
 111         sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
 112       };
 113
 114     # '.class1.class2' - match on intersection of classes
 115
 116     /\G((?:\.$sel_re)+)/gc and
 117       return do {
 118         my $cls = $1; $cls =~ s/^\.//;
 119         my @cl = split(/\./, $cls);
 120         sub {
 121           $_[0]->{attrs}{class}
 122           && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
 123         }
 124       };
 125
 126     confess "Couldn't parse $_ as starting with simple selector";
 127   }
 128 }
 129
 130 sub parse_selector {
 131   my $self = $_[0];
 132   my $sel = $_[1]; # my pos() only please
 133   die "No selector provided" unless $sel;
 134   local *_;
 135   for ($sel) {
 136     my @sub;
 137     PARSE: { do {
 138       push(@sub, $self->_raw_parse_simple_selector($_));
 139       last PARSE if (pos == length);
 140       /\G\s*,\s*/gc or confess "Selectors not comma separated";
 141     } until (pos == length) };
 142     return $sub[0] if (@sub == 1);
 143     return sub {
 144       foreach my $inner (@sub) {
 145         if (my $r = $inner->(@_)) { return $r }
 146       }
 147     };
 148   }
 149 }
 150
 151
 152 1;