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       $self->{name} && $self->{name} eq $name and
  18       $self->{attrs}{$attr} && $self->{attrs}{$attr} =~ $regex
  19    }
  20 };
  21
  22 my $match_attr_on_eq = sub {
  23    my ($self, $name, $attr, $val) = @_;
  24
  25    sub {
  26       $self->{name} && $self->{name} eq $name and
  27       $self->{attrs}{$attr} && $self->{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     # 'element' - match on tag name
  90
  91     /\G$sel_re/gc and
  92       return do {
  93         my $name = $1;
  94         sub { $_[0]->{name} && $_[0]->{name} eq $name }
  95       };
  96
  97     # '#id' - match on id attribute
  98
  99     /\G#$sel_re/gc and
 100       return do {
 101         my $id = $1;
 102         sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
 103       };
 104
 105     # '.class1.class2' - match on intersection of classes
 106
 107     /\G((?:\.$sel_re)+)/gc and
 108       return do {
 109         my $cls = $1; $cls =~ s/^\.//;
 110         my @cl = split(/\./, $cls);
 111         sub {
 112           $_[0]->{attrs}{class}
 113           && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
 114         }
 115       };
 116
 117     # 'el.class1' - element + class
 118
 119     /\G$sel_re\.$sel_re/gc and
 120       return do { $_[0]->$match_attr_on_eq($1, 'class', $3) };
 121
 122     # 'el#id' - element + id
 123
 124     /\G$sel_re#$sel_re/gc and
 125       return do { $_[0]->$match_attr_on_eq($1, 'id', $3) };
 126
 127     confess "Couldn't parse $_ as starting with simple selector";
 128   }
 129 }
 130
 131 sub parse_selector {
 132   my $self = $_[0];
 133   my $sel = $_[1]; # my pos() only please
 134   die "No selector provided" unless $sel;
 135   local *_;
 136   for ($sel) {
 137     my @sub;
 138     PARSE: { do {
 139       push(@sub, $self->_raw_parse_simple_selector($_));
 140       last PARSE if (pos == length);
 141       /\G\s*,\s*/gc or confess "Selectors not comma separated";
 142     } until (pos == length) };
 143     return $sub[0] if (@sub == 1);
 144     return sub {
 145       foreach my $inner (@sub) {
 146         if (my $r = $inner->(@_)) { return $r }
 147       }
 148     };
 149   }
 150 }
 151
 152
 153 1;