package HTML::Zoom::SelectorParser;
-use strict;
-use warnings FATAL => 'all';
+use strictures 1;
use base qw(HTML::Zoom::SubObject);
use Carp qw(confess);
my $sel_char = '-\w_';
my $sel_re = qr/([$sel_char]+)/;
+my $match_value_re = qr/"?$sel_re"?/;
+
sub new { bless({}, shift) }
}
};
- # 'el.class1' - element + class
+ # '[attr^=foo]' - match attribute with ^ anchored regex
+ /\G\[$sel_re\^=$match_value_re\]/gc and
+ return do {
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
+ }
+ };
+
+ # '[attr$=foo]' - match attribute with $ anchored regex
+ /\G\[$sel_re\$=$match_value_re\]/gc and
+ return do {
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
+ }
+ };
+
+ # '[attr*=foo] - match attribute with regex:
+ /\G\[$sel_re\*=$match_value_re\]/gc and
+ return do {
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/;
+ }
+ };
+
+ # '[attr~=bar]' - match attribute contains word
+ /\G\[$sel_re~=$match_value_re\]/gc and
+ return do {
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/\b\Q$value\E\b/;
+ }
+ };
- /\G$sel_re\.$sel_re/gc and
+ # '[attr!=bar]' - match attribute contains prefix (for language matches)
+ /\G\[$sel_re\|=$match_value_re\]/gc and
return do {
- my $cls = $1;
- my $name = $2;
+ my $attribute = $1;
+ my $value = $2;
sub {
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{class} && $_[0]->{attrs}{class} eq $cls
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E(?:-|$)/;
}
};
- confess "Couldn't parse $_ as starting with simple selector";
+ # '[attr=bar]' - match attributes
+ /\G\[$sel_re=$match_value_re\]/gc and
+ return do {
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} eq $value;
+ }
+ };
+
+ # '[attr!=bar]' - attributes doesn't match
+ /\G\[$sel_re!=$match_value_re\]/gc and
+ return do {
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ ! ($_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} eq $value);
+ }
+ };
+
+ # '[attr]' - match attribute being present:
+ /\G\[$sel_re\]/gc and
+ return do {
+ my $attribute = $1;
+ sub {
+ exists $_[0]->{attrs}{$attribute};
+ }
+ };
+
+ # none of the above matched, try catching some obvious errors:
+
+ # indicate unmatched square bracket:
+ /\G\[[^\]]*/gc and $_[0]->_blam('Unmatched [');
}
}
for ($sel) {
my @sub;
PARSE: { do {
- push(@sub, $self->_raw_parse_simple_selector($_));
- last PARSE if (pos == length);
- /\G\s*,\s*/gc or confess "Selectors not comma separated";
- } until (pos == length) };
+
+ my @this_chain;
+
+ # slurp selectors until we find something else:
+ while( my $sel = $self->_raw_parse_simple_selector($_) ){
+ push @this_chain, $sel;
+ }
+
+ if( @this_chain == 1 )
+ {
+ push @sub, @this_chain;
+ }
+ else{
+ # make a compound match closure of everything
+ # in this chain of selectors:
+ push @sub, sub{
+ my $r;
+ for my $inner ( @this_chain ){
+ if( ! ($r = $inner->( @_ )) ){
+ return $r;
+ }
+ }
+ return $r;
+ }
+ }
+
+ # now we're at the end or a delimiter:
+ last PARSE if( pos == length );
+ /\G\s*,\s*/gc or do {
+ /\G(.*)/;
+ $self->_blam( "Selectors not comma separated." );
+ }
+
+ } until (pos == length) };
return $sub[0] if (@sub == 1);
return sub {
foreach my $inner (@sub) {
}
+sub _blam {
+ my ($self, $error) = @_;
+ my $hat = (' ' x (pos||0)).'^';
+ die "Error parsing dispatch specification: ${error}\n
+${_}
+${hat} here\n";
+}
+
1;