1 package HTML::Zoom::SelectorParser;
4 use warnings FATAL => 'all';
5 use base qw(HTML::Zoom::SubObject);
9 my $sel_re = qr/([$sel_char]+)/;
10 my $match_value_re = qr/"?$sel_re"?/;
13 sub new { bless({}, shift) }
15 sub _raw_parse_simple_selector {
16 for ($_[1]) { # same pos() as outside
18 # '*' - match anything
23 # 'element' - match on tag name
28 sub { $_[0]->{name} && $_[0]->{name} eq $name }
31 # '#id' - match on id attribute
36 sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id }
39 # '.class1.class2' - match on intersection of classes
41 /\G((?:\.$sel_re)+)/gc and
43 my $cls = $1; $cls =~ s/^\.//;
44 my @cl = split(/\./, $cls);
47 && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl
51 # '[attr^=foo]' - match attribute with ^ anchored regex
52 /\G\[$sel_re\^=$match_value_re\]/gc and
57 $_[0]->{attrs}{$attribute}
58 && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/;
62 # '[attr$=foo]' - match attribute with $ anchored regex
63 /\G\[$sel_re\$=$match_value_re\]/gc and
68 $_[0]->{attrs}{$attribute}
69 && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/;
73 # '[attr*=foo] - match attribute with regex:
74 /\G\[$sel_re\*=$match_value_re\]/gc and
79 $_[0]->{attrs}{$attribute}
80 && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/;
84 # '[attr=bar]' - match attributes
85 /\G\[$sel_re=$match_value_re\]/gc and
90 $_[0]->{attrs}{$attribute}
91 && $_[0]->{attrs}{$attribute} eq $value;
95 # '[attr] - match attribute being present:
100 exists $_[0]->{attrs}{$attribute};
108 my $sel = $_[1]; # my pos() only please
109 die "No selector provided" unless $sel;
117 # slurp selectors until we find something else:
118 while( my $sel = $self->_raw_parse_simple_selector($_) ){
119 push @this_chain, $sel;
122 if( @this_chain == 1 )
124 push @sub, @this_chain;
127 # make a compound match closure of everything
128 # in this chain of selectors:
131 for my $inner ( @this_chain ){
132 if( ! ($r = $inner->( @_ )) ){
140 # now we're at the end or a delimiter:
141 last PARSE if( pos == length );
142 /\G\s*,\s*/gc or do {
144 $self->_blam( "Selectors not comma separated." );
147 } until (pos == length) };
148 return $sub[0] if (@sub == 1);
150 foreach my $inner (@sub) {
151 if (my $r = $inner->(@_)) { return $r }
159 my ($self, $error) = @_;
160 my $hat = (' ' x (pos||0)).'^';
161 die "Error parsing dispatch specification: ${error}\n