Commit | Line | Data |
456a815d |
1 | package HTML::Zoom::SelectorParser; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
6d0f20a6 |
5 | use base qw(HTML::Zoom::SubObject); |
456a815d |
6 | use Carp qw(confess); |
7 | |
8 | my $sel_char = '-\w_'; |
9 | my $sel_re = qr/([$sel_char]+)/; |
682fa876 |
10 | my $match_value_re = qr/"?$sel_re"?/; |
456a815d |
11 | |
96e44ffd |
12 | |
682fa876 |
13 | sub new { bless({}, shift) } |
96e44ffd |
14 | |
456a815d |
15 | sub _raw_parse_simple_selector { |
16 | for ($_[1]) { # same pos() as outside |
17 | |
18 | # '*' - match anything |
19 | |
20 | /\G\*/gc and |
21 | return sub { 1 }; |
22 | |
23 | # 'element' - match on tag name |
24 | |
25 | /\G$sel_re/gc and |
26 | return do { |
27 | my $name = $1; |
28 | sub { $_[0]->{name} && $_[0]->{name} eq $name } |
29 | }; |
30 | |
31 | # '#id' - match on id attribute |
32 | |
33 | /\G#$sel_re/gc and |
34 | return do { |
35 | my $id = $1; |
36 | sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id } |
37 | }; |
38 | |
39 | # '.class1.class2' - match on intersection of classes |
40 | |
41 | /\G((?:\.$sel_re)+)/gc and |
42 | return do { |
43 | my $cls = $1; $cls =~ s/^\.//; |
44 | my @cl = split(/\./, $cls); |
45 | sub { |
46 | $_[0]->{attrs}{class} |
6d0f20a6 |
47 | && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl |
456a815d |
48 | } |
49 | }; |
50 | |
682fa876 |
51 | # '[attr^=foo]' - match attribute with ^ anchored regex |
52 | /\G\[$sel_re\^=$match_value_re\]/gc and |
6818876e |
53 | return do { |
682fa876 |
54 | my $attribute = $1; |
55 | my $value = $2; |
6818876e |
56 | sub { |
57 | $_[0]->{attrs}{$attribute} |
58 | && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/; |
59 | } |
682fa876 |
60 | }; |
61 | |
62 | # '[attr$=foo]' - match attribute with $ anchored regex |
63 | /\G\[$sel_re\$=$match_value_re\]/gc and |
6818876e |
64 | return do { |
682fa876 |
65 | my $attribute = $1; |
66 | my $value = $2; |
6818876e |
67 | sub { |
68 | $_[0]->{attrs}{$attribute} |
69 | && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/; |
70 | } |
682fa876 |
71 | }; |
72 | |
73 | # '[attr*=foo] - match attribute with regex: |
74 | /\G\[$sel_re\*=$match_value_re\]/gc and |
6818876e |
75 | return do { |
682fa876 |
76 | my $attribute = $1; |
77 | my $value = $2; |
6818876e |
78 | sub { |
79 | $_[0]->{attrs}{$attribute} |
80 | && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E/; |
81 | } |
682fa876 |
82 | }; |
83 | |
84 | # '[attr=bar]' - match attributes |
85 | /\G\[$sel_re=$match_value_re\]/gc and |
86 | return do { |
87 | my $attribute = $1; |
88 | my $value = $2; |
6818876e |
89 | sub { |
682fa876 |
90 | $_[0]->{attrs}{$attribute} |
91 | && $_[0]->{attrs}{$attribute} eq $value; |
92 | } |
93 | }; |
94 | |
95 | # '[attr] - match attribute being present: |
96 | /\G\[$sel_re\]/gc and |
97 | return do { |
98 | my $attribute = $1; |
6818876e |
99 | sub { |
100 | exists $_[0]->{attrs}{$attribute}; |
101 | } |
682fa876 |
102 | } |
456a815d |
103 | } |
104 | } |
105 | |
106 | sub parse_selector { |
107 | my $self = $_[0]; |
108 | my $sel = $_[1]; # my pos() only please |
109 | die "No selector provided" unless $sel; |
110 | local *_; |
111 | for ($sel) { |
112 | my @sub; |
113 | PARSE: { do { |
682fa876 |
114 | |
115 | my @this_chain; |
116 | |
117 | # slurp selectors until we find something else: |
118 | while( my $sel = $self->_raw_parse_simple_selector($_) ){ |
119 | push @this_chain, $sel; |
120 | } |
121 | |
122 | if( @this_chain == 1 ) |
123 | { |
124 | push @sub, @this_chain; |
125 | } |
126 | else{ |
127 | # make a compound match closure of everything |
128 | # in this chain of selectors: |
129 | push @sub, sub{ |
130 | my $r; |
131 | for my $inner ( @this_chain ){ |
132 | if( ! ($r = $inner->( @_ )) ){ |
133 | return $r; |
134 | } |
135 | } |
136 | return $r; |
137 | } |
138 | } |
139 | |
140 | # now we're at the end or a delimiter: |
141 | last PARSE if( pos == length ); |
142 | /\G\s*,\s*/gc or do { |
143 | /\G(.*)/; |
144 | $self->_blam( "Selectors not comma separated." ); |
145 | } |
146 | |
147 | } until (pos == length) }; |
456a815d |
148 | return $sub[0] if (@sub == 1); |
149 | return sub { |
150 | foreach my $inner (@sub) { |
151 | if (my $r = $inner->(@_)) { return $r } |
152 | } |
153 | }; |
154 | } |
7871f2ff |
155 | } |
156 | |
456a815d |
157 | |
682fa876 |
158 | sub _blam { |
159 | my ($self, $error) = @_; |
160 | my $hat = (' ' x (pos||0)).'^'; |
161 | die "Error parsing dispatch specification: ${error}\n |
162 | ${_} |
163 | ${hat} here\n"; |
164 | } |
165 | |
456a815d |
166 | 1; |