X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHTML%2FZoom%2FSelectorParser.pm;h=ef61d93e349449a692fefebaa395c870cd7817f6;hb=24725e7b32b680b376c06b1f9d641ec11fc1d067;hp=6acc029741eee8b0f7f061e3858eef2d3790f107;hpb=96e44ffd665ed69d3f43c356dc2108884a06f8d1;p=catagits%2FHTML-Zoom.git diff --git a/lib/HTML/Zoom/SelectorParser.pm b/lib/HTML/Zoom/SelectorParser.pm index 6acc029..ef61d93 100644 --- a/lib/HTML/Zoom/SelectorParser.pm +++ b/lib/HTML/Zoom/SelectorParser.pm @@ -7,26 +7,10 @@ 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) } - -my $match_attr_on_regex = sub { - my ($self, $name, $attr, $regex) = @_; - - sub { - $self->{name} && $self->{name} eq $name and - $self->{attrs}{$attr} && $self->{attrs}{$attr} =~ $regex - } -}; -my $match_attr_on_eq = sub { - my ($self, $name, $attr, $val) = @_; - - sub { - $self->{name} && $self->{name} eq $name and - $self->{attrs}{$attr} && $self->{attrs}{$attr} eq $val - } -}; +sub new { bless({}, shift) } sub _raw_parse_simple_selector { for ($_[1]) { # same pos() as outside @@ -36,56 +20,6 @@ sub _raw_parse_simple_selector { /\G\*/gc and return sub { 1 }; - # 'el[attr~="foo"] - - /\G$sel_re\[$sel_re~="$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 - } - }; - - # 'el[attr^="foo"] - - /\G$sel_re\[$sel_re\^="$sel_re"\]/gc and - return do { $_[0]->$match_attr_on_regex($1, $2, qr/^\Q$3\E/) }; - - # 'el[attr$="foo"] - - /\G$sel_re\[$sel_re\$="$sel_re"\]/gc and - return do { $_[0]->$match_attr_on_regex($1, $2, qr/\Q$3\E$/) }; - - # 'el[attr*="foo"] - - /\G$sel_re\[$sel_re\*="$sel_re"\]/gc and - return do { $_[0]->$match_attr_on_regex($1, $2, qr/\Q$3\E/) }; - - # 'el[attr="foo"] - - /\G$sel_re\[$sel_re="$sel_re"\]/gc and - return do { $_[0]->$match_attr_on_eq($1, $2, $3) }; - - # 'el[attr] - - /\G$sel_re\[$sel_re\]/gc and - return do { - my $name = $1; - my $attr = $2; - sub { - $_[0]->{name} && $_[0]->{name} eq $name && $_[0]->{attrs}{$attr} - } - }; - # 'element' - match on tag name /\G$sel_re/gc and @@ -114,17 +48,85 @@ sub _raw_parse_simple_selector { } }; - # '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} + && grep { $_ eq $value } split(' ', $_[0]->{attrs}{$attribute}); + } + }; - /\G$sel_re\.$sel_re/gc and - return do { $_[0]->$match_attr_on_eq($1, 'class', $3) }; + # '[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; + } + }; - # 'el#id' - element + id + # '[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); + } + }; - /\G$sel_re#$sel_re/gc and - return do { $_[0]->$match_attr_on_eq($1, 'id', $3) }; + # '[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: - confess "Couldn't parse $_ as starting with simple selector"; + # indicate unmatched square bracket: + /\G\[[^\]]*/gc and $_[0]->_blam('Unmatched ['); } } @@ -136,10 +138,40 @@ sub parse_selector { 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) { @@ -150,4 +182,12 @@ sub parse_selector { } +sub _blam { + my ($self, $error) = @_; + my $hat = (' ' x (pos||0)).'^'; + die "Error parsing dispatch specification: ${error}\n +${_} +${hat} here\n"; +} + 1;