1 package HTML::Zoom::SelectorParser;
4 use base qw(HTML::Zoom::SubObject);
8 my $sel_re = qr/([$sel_char]+)/;
9 my $match_value_re = qr/"?$sel_re"?/;
12 sub new { bless({}, shift) }
14 sub _raw_parse_simple_selector {
15 for ($_[1]) { # same pos() as outside
17 # '*' - match anything
22 # 'element' - match on tag name
27 sub { $_[0]->{name} && $_[0]->{name} eq $name }
30 # '#id' - match on id attribute
35 sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
38 # '.class1.class2' - match on intersection of classes
40 /\G((?:\.$sel_re)+)/gc and
42 my $cls = $1; $cls =~ s/^\.//;
43 my @cl = split(/\./, $cls);
46 && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
50 # '[attr^=foo]' - match attribute with ^ anchored regex
51 /\G\[$sel_re\^=$match_value_re\]/gc and
56 $_[0]->{attrs}{$attribute}
57 && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
61 # '[attr$=foo]' - match attribute with $ anchored regex
62 /\G\[$sel_re\$=$match_value_re\]/gc and
67 $_[0]->{attrs}{$attribute}
68 && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
72 # '[attr*=foo] - match attribute with regex:
73 /\G\[$sel_re\*=$match_value_re\]/gc and
78 $_[0]->{attrs}{$attribute}
79 && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/;
83 # '[attr~=bar]' - match attribute contains word
84 /\G\[$sel_re~=$match_value_re\]/gc and
89 $_[0]->{attrs}{$attribute}
90 && $_[0]->{attrs}{$attribute} =~ qr/\b\Q$value\E\b/;
94 # '[attr!=bar]' - match attribute contains prefix (for language matches)
95 /\G\[$sel_re\|=$match_value_re\]/gc and
100 $_[0]->{attrs}{$attribute}
101 && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E(?:-|$)/;
105 # '[attr=bar]' - match attributes
106 /\G\[$sel_re=$match_value_re\]/gc and
111 $_[0]->{attrs}{$attribute}
112 && $_[0]->{attrs}{$attribute} eq $value;
116 # '[attr!=bar]' - attributes doesn't match
117 /\G\[$sel_re!=$match_value_re\]/gc and
122 ! ($_[0]->{attrs}{$attribute}
123 && $_[0]->{attrs}{$attribute} eq $value);
127 # '[attr]' - match attribute being present:
128 /\G\[$sel_re\]/gc and
132 exists $_[0]->{attrs}{$attribute};
136 # none of the above matched, try catching some obvious errors:
138 # indicate unmatched square bracket:
139 /\G\[[^\]]*/gc and $_[0]->_blam('Unmatched [');
145 my $sel = $_[1]; # my pos() only please
146 die "No selector provided" unless $sel;
154 # slurp selectors until we find something else:
155 while( my $sel = $self->_raw_parse_simple_selector($_) ){
156 push @this_chain, $sel;
159 if( @this_chain == 1 )
161 push @sub, @this_chain;
164 # make a compound match closure of everything
165 # in this chain of selectors:
168 for my $inner ( @this_chain ){
169 if( ! ($r = $inner->( @_ )) ){
177 # now we're at the end or a delimiter:
178 last PARSE if( pos == length );
179 /\G\s*,\s*/gc or do {
181 $self->_blam( "Selectors not comma separated." );
184 } until (pos == length) };
185 return $sub[0] if (@sub == 1);
187 foreach my $inner (@sub) {
188 if (my $r = $inner->(@_)) { return $r }
196 my ($self, $error) = @_;
197 my $hat = (' ' x (pos||0)).'^';
198 die "Error parsing dispatch specification: ${error}\n