my $sel_char = '-\w_';
my $sel_re = qr/([$sel_char]+)/;
+my $match_value_re = qr/"?$sel_re"?/;
+
sub new { bless({}, shift) }
/\G\*/gc and
return sub { 1 };
- # 'el[attr~="foo"]
+ # 'element' - match on tag name
- /\G$sel_re\[$sel_re~="$sel_re"\]/gc and
+ /\G$sel_re/gc and
return do {
my $name = $1;
- my $attr = $2;
- my $val = $3;
- sub {
- if (
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{$attr}
- ) {
- my %vals = map { $_ => 1 } split /\s+/, $_[0]->{attrs}{$attr};
- return $vals{$val}
- }
- return undef
- }
+ sub { $_[0]->{name} && $_[0]->{name} eq $name }
};
- # 'el[attr^="foo"]
+ # '#id' - match on id attribute
- /\G$sel_re\[$sel_re\^="$sel_re"\]/gc and
+ /\G#$sel_re/gc and
return do {
- my $name = $1;
- my $attr = $2;
- my $val = $3;
- sub {
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ /^\Q$val\E/
- }
+ my $id = $1;
+ sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
};
- # 'el[attr$="foo"]
+ # '.class1.class2' - match on intersection of classes
- /\G$sel_re\[$sel_re\$="$sel_re"\]/gc and
+ /\G((?:\.$sel_re)+)/gc and
return do {
- my $name = $1;
- my $attr = $2;
- my $val = $3;
+ my $cls = $1; $cls =~ s/^\.//;
+ my @cl = split(/\./, $cls);
sub {
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ /\Q$val\E$/
+ $_[0]->{attrs}{class}
+ && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
}
};
- # 'el[attr*="foo"]
-
- /\G$sel_re\[$sel_re\*="$sel_re"\]/gc and
+ # '[attr^=foo]' - match attribute with ^ anchored regex
+ /\G\[$sel_re\^=$match_value_re\]/gc and
return do {
- my $name = $1;
- my $attr = $2;
- my $val = $3;
+ my $attribute = $1;
+ my $value = $2;
sub {
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ /\Q$val\E/
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
}
};
- # 'el[attr="foo"]
-
- /\G$sel_re\[$sel_re="$sel_re"\]/gc and
+ # '[attr$=foo]' - match attribute with $ anchored regex
+ /\G\[$sel_re\$=$match_value_re\]/gc and
return do {
- my $name = $1;
- my $attr = $2;
- my $val = $3;
+ my $attribute = $1;
+ my $value = $2;
sub {
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} eq $val
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
}
};
- # 'el[attr]
-
- /\G$sel_re\[$sel_re\]/gc and
+ # '[attr*=foo] - match attribute with regex:
+ /\G\[$sel_re\*=$match_value_re\]/gc and
return do {
- my $name = $1;
- my $attr = $2;
+ my $attribute = $1;
+ my $value = $2;
sub {
- $_[0]->{name} && $_[0]->{name} eq $name && $_[0]->{attrs}{$attr}
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/;
}
};
- # 'element' - match on tag name
-
- /\G$sel_re/gc and
+ # '[attr~=bar]' - match attribute contains word
+ /\G\[$sel_re~=$match_value_re\]/gc and
return do {
- my $name = $1;
- sub { $_[0]->{name} && $_[0]->{name} eq $name }
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/\b\Q$value\E\b/;
+ }
};
- # '#id' - match on id attribute
-
- /\G#$sel_re/gc and
+ # '[attr!=bar]' - match attribute contains prefix (for language matches)
+ /\G\[$sel_re\|=$match_value_re\]/gc and
return do {
- my $id = $1;
- sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
+ my $attribute = $1;
+ my $value = $2;
+ sub {
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E(?:-|$)/;
+ }
};
- # '.class1.class2' - match on intersection of classes
-
- /\G((?:\.$sel_re)+)/gc and
+ # '[attr=bar]' - match attributes
+ /\G\[$sel_re=$match_value_re\]/gc and
return do {
- my $cls = $1; $cls =~ s/^\.//;
- my @cl = split(/\./, $cls);
+ my $attribute = $1;
+ my $value = $2;
sub {
- $_[0]->{attrs}{class}
- && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
+ $_[0]->{attrs}{$attribute}
+ && $_[0]->{attrs}{$attribute} eq $value;
}
};
- # 'el.class1' - element + class
-
- /\G$sel_re\.$sel_re/gc and
+ # '[attr!=bar]' - attributes doesn't match
+ /\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} eq $value);
}
};
- # 'el#id' - element + id
-
- /\G$sel_re#$sel_re/gc and
+ # '[attr]' - match attribute being present:
+ /\G\[$sel_re\]/gc and
return do {
- my $id = $1;
- my $name = $2;
+ my $attribute = $1;
sub {
- $_[0]->{name} && $_[0]->{name} eq $name and
- $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id
+ exists $_[0]->{attrs}{$attribute};
}
- };
+ };
+
+ # none of the above matched, try catching some obvious errors:
- confess "Couldn't parse $_ as starting with simple selector";
+ # 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;