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 |
53 | return do{ |
54 | my $attribute = $1; |
55 | my $value = $2; |
56 | $_[0]->{attrs}{$attribute} |
57 | && $_[0]->{attrs}{$attribute} =~ qr/^\Q$value\E/; |
58 | }; |
59 | |
60 | # '[attr$=foo]' - match attribute with $ anchored regex |
61 | /\G\[$sel_re\$=$match_value_re\]/gc and |
62 | return do{ |
63 | my $attribute = $1; |
64 | my $value = $2; |
65 | $_[0]->{attrs}{$attribute} |
66 | && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/; |
67 | }; |
68 | |
69 | # '[attr*=foo] - match attribute with regex: |
70 | /\G\[$sel_re\*=$match_value_re\]/gc and |
71 | return do{ |
72 | my $attribute = $1; |
73 | my $value = $2; |
74 | $_[0]->{attrs}{$attribute} |
75 | && $_[0]->{attrs}{$attribute} =~ qr/\Q$value\E$/; |
76 | }; |
77 | |
78 | # '[attr=bar]' - match attributes |
79 | /\G\[$sel_re=$match_value_re\]/gc and |
80 | return do { |
81 | my $attribute = $1; |
82 | my $value = $2; |
83 | sub{ |
84 | $_[0]->{attrs}{$attribute} |
85 | && $_[0]->{attrs}{$attribute} eq $value; |
86 | } |
87 | }; |
88 | |
89 | # '[attr] - match attribute being present: |
90 | /\G\[$sel_re\]/gc and |
91 | return do { |
92 | my $attribute = $1; |
93 | $_[0]->{attrs}{$attribute}; |
94 | } |
456a815d |
95 | } |
96 | } |
97 | |
98 | sub parse_selector { |
99 | my $self = $_[0]; |
100 | my $sel = $_[1]; # my pos() only please |
101 | die "No selector provided" unless $sel; |
102 | local *_; |
103 | for ($sel) { |
104 | my @sub; |
105 | PARSE: { do { |
682fa876 |
106 | |
107 | my @this_chain; |
108 | |
109 | # slurp selectors until we find something else: |
110 | while( my $sel = $self->_raw_parse_simple_selector($_) ){ |
111 | push @this_chain, $sel; |
112 | } |
113 | |
114 | if( @this_chain == 1 ) |
115 | { |
116 | push @sub, @this_chain; |
117 | } |
118 | else{ |
119 | # make a compound match closure of everything |
120 | # in this chain of selectors: |
121 | push @sub, sub{ |
122 | my $r; |
123 | for my $inner ( @this_chain ){ |
124 | if( ! ($r = $inner->( @_ )) ){ |
125 | return $r; |
126 | } |
127 | } |
128 | return $r; |
129 | } |
130 | } |
131 | |
132 | # now we're at the end or a delimiter: |
133 | last PARSE if( pos == length ); |
134 | /\G\s*,\s*/gc or do { |
135 | /\G(.*)/; |
136 | $self->_blam( "Selectors not comma separated." ); |
137 | } |
138 | |
139 | } until (pos == length) }; |
456a815d |
140 | return $sub[0] if (@sub == 1); |
141 | return sub { |
142 | foreach my $inner (@sub) { |
143 | if (my $r = $inner->(@_)) { return $r } |
144 | } |
145 | }; |
146 | } |
7871f2ff |
147 | } |
148 | |
456a815d |
149 | |
682fa876 |
150 | sub _blam { |
151 | my ($self, $error) = @_; |
152 | my $hat = (' ' x (pos||0)).'^'; |
153 | die "Error parsing dispatch specification: ${error}\n |
154 | ${_} |
155 | ${hat} here\n"; |
156 | } |
157 | |
456a815d |
158 | 1; |