Commit | Line | Data |
456a815d |
1 | package HTML::Zoom::SelectorParser; |
2 | |
3 | use strict; |
9463c1dc |
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]+)/; |
10 | |
11 | sub new { bless({}, shift) } |
12 | |
5fc8832f |
13 | my $match_attr_on_regex = sub { |
14 | my ($self, $name, $attr, $regex) = @_; |
15 | |
16 | sub { |
9463c1dc |
17 | $_[0]->{name} && $_[0]->{name} eq $name and |
18 | $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} =~ $regex |
5fc8832f |
19 | } |
20 | }; |
21 | |
22 | my $match_attr_on_eq = sub { |
23 | my ($self, $name, $attr, $val) = @_; |
24 | |
25 | sub { |
9463c1dc |
26 | $_[0]->{name} && $_[0]->{name} eq $name and |
27 | $_[0]->{attrs}{$attr} && $_[0]->{attrs}{$attr} eq $val |
5fc8832f |
28 | } |
29 | }; |
30 | |
456a815d |
31 | sub _raw_parse_simple_selector { |
32 | for ($_[1]) { # same pos() as outside |
33 | |
34 | # '*' - match anything |
35 | |
36 | /\G\*/gc and |
37 | return sub { 1 }; |
38 | |
5635fd40 |
39 | # 'el[attr~="foo"] |
40 | |
41 | /\G$sel_re\[$sel_re~="$sel_re"\]/gc and |
42 | return do { |
43 | my $name = $1; |
44 | my $attr = $2; |
45 | my $val = $3; |
46 | sub { |
47 | if ( |
48 | $_[0]->{name} && $_[0]->{name} eq $name and |
49 | $_[0]->{attrs}{$attr} |
50 | ) { |
51 | my %vals = map { $_ => 1 } split /\s+/, $_[0]->{attrs}{$attr}; |
52 | return $vals{$val} |
53 | } |
54 | return undef |
55 | } |
56 | }; |
57 | |
4b46c7a5 |
58 | # 'el[attr^="foo"] |
59 | |
60 | /\G$sel_re\[$sel_re\^="$sel_re"\]/gc and |
5fc8832f |
61 | return do { $_[0]->$match_attr_on_regex($1, $2, qr/^\Q$3\E/) }; |
4b46c7a5 |
62 | |
47ac1c9a |
63 | # 'el[attr$="foo"] |
64 | |
65 | /\G$sel_re\[$sel_re\$="$sel_re"\]/gc and |
5fc8832f |
66 | return do { $_[0]->$match_attr_on_regex($1, $2, qr/\Q$3\E$/) }; |
47ac1c9a |
67 | |
827f965b |
68 | # 'el[attr*="foo"] |
69 | |
70 | /\G$sel_re\[$sel_re\*="$sel_re"\]/gc and |
5fc8832f |
71 | return do { $_[0]->$match_attr_on_regex($1, $2, qr/\Q$3\E/) }; |
827f965b |
72 | |
03e514ef |
73 | # 'el[attr="foo"] |
74 | |
75 | /\G$sel_re\[$sel_re="$sel_re"\]/gc and |
9463c1dc |
76 | return do { $_[0]->$match_attr_on_eq( $1, $2, $3) }; |
03e514ef |
77 | |
4b46c7a5 |
78 | # 'el[attr] |
79 | |
80 | /\G$sel_re\[$sel_re\]/gc and |
81 | return do { |
82 | my $name = $1; |
83 | my $attr = $2; |
84 | sub { |
85 | $_[0]->{name} && $_[0]->{name} eq $name && $_[0]->{attrs}{$attr} |
86 | } |
87 | }; |
88 | |
9463c1dc |
89 | # 'el.class1' - element + class |
90 | |
91 | /\G$sel_re\.$sel_re/gc and |
92 | return do { $_[0]->$match_attr_on_eq($1, 'class', $2) }; |
93 | |
94 | # 'el#id' - element + id |
95 | /\G$sel_re#$sel_re/gc and |
96 | return do { $_[0]->$match_attr_on_eq($1, 'id', $2) }; |
97 | |
456a815d |
98 | # 'element' - match on tag name |
99 | |
100 | /\G$sel_re/gc and |
101 | return do { |
102 | my $name = $1; |
103 | sub { $_[0]->{name} && $_[0]->{name} eq $name } |
104 | }; |
105 | |
106 | # '#id' - match on id attribute |
107 | |
108 | /\G#$sel_re/gc and |
109 | return do { |
110 | my $id = $1; |
111 | sub { $_[0]->{attrs}{id} && $_[0]->{attrs}{id} eq $id } |
112 | }; |
113 | |
114 | # '.class1.class2' - match on intersection of classes |
115 | |
116 | /\G((?:\.$sel_re)+)/gc and |
117 | return do { |
118 | my $cls = $1; $cls =~ s/^\.//; |
119 | my @cl = split(/\./, $cls); |
120 | sub { |
121 | $_[0]->{attrs}{class} |
6d0f20a6 |
122 | && !grep $_[0]->{attrs}{class} !~ /(^|\s+)$_($|\s+)/, @cl |
456a815d |
123 | } |
124 | }; |
125 | |
126 | confess "Couldn't parse $_ as starting with simple selector"; |
127 | } |
128 | } |
129 | |
130 | sub parse_selector { |
131 | my $self = $_[0]; |
132 | my $sel = $_[1]; # my pos() only please |
133 | die "No selector provided" unless $sel; |
134 | local *_; |
135 | for ($sel) { |
136 | my @sub; |
137 | PARSE: { do { |
138 | push(@sub, $self->_raw_parse_simple_selector($_)); |
139 | last PARSE if (pos == length); |
50b9ca86 |
140 | #/\G\s*,\s*/gc or confess "Selectors not comma separated"; |
456a815d |
141 | } until (pos == length) }; |
142 | return $sub[0] if (@sub == 1); |
143 | return sub { |
144 | foreach my $inner (@sub) { |
145 | if (my $r = $inner->(@_)) { return $r } |
146 | } |
147 | }; |
148 | } |
50b9ca86 |
149 | } |
150 | |
456a815d |
151 | |
152 | 1; |