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