Commit | Line | Data |
920d6222 |
1 | package Web::Simple::DispatchParser; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
6 | sub new { bless({}, ref($_[0])||$_[0]) } |
7 | |
8 | sub _blam { |
9 | my ($self, $error) = @_; |
a4ec359d |
10 | my $hat = (' ' x (pos||0)).'^'; |
920d6222 |
11 | die "Error parsing dispatch specification: ${error}\n |
12 | ${_} |
13 | ${hat} here\n"; |
14 | } |
15 | |
16 | sub parse_dispatch_specification { |
17 | my ($self, $spec) = @_; |
c6ea9542 |
18 | return $self->_parse_spec($spec); |
19 | } |
20 | |
21 | sub _parse_spec { |
b0420ad6 |
22 | my ($self, $spec, $nested) = @_; |
c6ea9542 |
23 | for ($_[1]) { |
920d6222 |
24 | my @match; |
920d6222 |
25 | /^\G\s*/; # eat leading whitespace |
26 | PARSE: { do { |
c6ea9542 |
27 | push @match, $self->_parse_spec_section($_) |
920d6222 |
28 | or $self->_blam("Unable to work out what the next section is"); |
b0420ad6 |
29 | if (/\G\)/gc) { |
30 | $self->_blam("Found closing ) with no opening (") unless $nested; |
31 | last PARSE; |
32 | } |
920d6222 |
33 | last PARSE if (pos == length); |
c6ea9542 |
34 | $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) |
35 | or $self->_blam('No valid combinator - expected + or |'); |
920d6222 |
36 | } until (pos == length) }; # accept trailing whitespace |
b0420ad6 |
37 | if ($nested and pos == length) { |
a4ec359d |
38 | pos = $nested - 1; |
b0420ad6 |
39 | $self->_blam("No closing ) found for opening ("); |
40 | } |
920d6222 |
41 | return $match[0] if (@match == 1); |
42 | return sub { |
43 | my $env = { %{$_[0]} }; |
44 | my $new_env; |
45 | my @got; |
46 | foreach my $match (@match) { |
47 | if (my @this_got = $match->($env)) { |
48 | my %change_env = %{shift(@this_got)}; |
49 | @{$env}{keys %change_env} = values %change_env; |
50 | @{$new_env}{keys %change_env} = values %change_env; |
51 | push @got, @this_got; |
52 | } else { |
53 | return; |
54 | } |
55 | } |
56 | return ($new_env, @got); |
57 | }; |
58 | } |
59 | } |
60 | |
9b9866ae |
61 | sub _parse_spec_combinator { |
62 | my ($self, $spec, $match) = @_; |
63 | for ($_[1]) { |
64 | |
65 | /\G\+/gc and |
66 | return $match; |
67 | |
68 | /\G\|/gc and |
69 | return do { |
70 | my @match = $match; |
71 | PARSE: { do { |
72 | push @match, $self->_parse_spec_section($_) |
73 | or $self->_blam("Unable to work out what the next section is"); |
74 | last PARSE if (pos == length); |
75 | last PARSE unless /\G\|/gc; # give up when next thing isn't | |
76 | } until (pos == length) }; # accept trailing whitespace |
77 | return sub { |
78 | foreach my $try (@match) { |
79 | if (my @ret = $try->(@_)) { |
80 | return @ret; |
81 | } |
82 | } |
83 | return; |
84 | }; |
85 | }; |
86 | } |
87 | return; |
88 | } |
89 | |
920d6222 |
90 | sub _parse_spec_section { |
91 | my ($self) = @_; |
92 | for ($_[1]) { |
93 | |
94 | # GET POST PUT HEAD ... |
95 | |
96 | /\G([A-Z]+)/gc and |
97 | return $self->_http_method_match($_, $1); |
98 | |
99 | # /... |
100 | |
101 | /\G(?=\/)/gc and |
102 | return $self->_url_path_match($_); |
103 | |
c6ea9542 |
104 | # .* and .html |
105 | |
106 | /\G\.(\*|\w+)/gc and |
920d6222 |
107 | return $self->_url_extension_match($_, $1); |
b0420ad6 |
108 | |
2ee4ab06 |
109 | # (...) |
b0420ad6 |
110 | |
111 | /\G\(/gc and |
112 | return $self->_parse_spec($_, pos); |
2ee4ab06 |
113 | |
114 | # !something |
115 | |
116 | /\G!/gc and |
117 | return do { |
118 | my $match = $self->_parse_spec_section($_); |
119 | return sub { |
120 | return {} unless $match->(@_); |
121 | return; |
122 | }; |
123 | }; |
920d6222 |
124 | |
9b9866ae |
125 | # ?<param spec> |
126 | /\G\?/gc and |
127 | return $self->_parse_param_handler($_, 'query'); |
c6ea9542 |
128 | } |
9b9866ae |
129 | return; # () will trigger the blam in our caller |
c6ea9542 |
130 | } |
131 | |
920d6222 |
132 | sub _http_method_match { |
133 | my ($self, $str, $method) = @_; |
920d6222 |
134 | sub { shift->{REQUEST_METHOD} eq $method ? {} : () }; |
135 | } |
136 | |
137 | sub _url_path_match { |
138 | my ($self) = @_; |
920d6222 |
139 | for ($_[1]) { |
140 | my @path; |
da8429c9 |
141 | my $full_path = '$'; |
142 | PATH: while (/\G\//gc) { |
143 | /\G\.\.\./gc |
144 | and do { |
145 | $full_path = ''; |
146 | last PATH; |
147 | }; |
920d6222 |
148 | push @path, $self->_url_path_segment_match($_) |
149 | or $self->_blam("Couldn't parse path match segment"); |
150 | } |
da8429c9 |
151 | my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$'); |
152 | $re = qr/$re/; |
153 | if ($full_path) { |
154 | return sub { |
155 | if (my @cap = (shift->{PATH_INFO} =~ /$re/)) { |
156 | $cap[0] = {}; return @cap; |
157 | } |
158 | return (); |
159 | }; |
160 | } |
920d6222 |
161 | return sub { |
162 | if (my @cap = (shift->{PATH_INFO} =~ /$re/)) { |
da8429c9 |
163 | $cap[0] = { PATH_INFO => pop(@cap) }; return @cap; |
920d6222 |
164 | } |
165 | return (); |
166 | }; |
167 | } |
168 | return; |
169 | } |
170 | |
171 | sub _url_path_segment_match { |
172 | my ($self) = @_; |
173 | for ($_[1]) { |
174 | # trailing / -> require / on end of URL |
175 | /\G(?:(?=\s)|$)/gc and |
176 | return '$'; |
177 | # word chars only -> exact path part match |
178 | /\G(\w+)/gc and |
179 | return "\Q$1"; |
28f3dfd5 |
180 | # ** -> capture unlimited path parts |
181 | /\G\*\*/gc and |
182 | return '(.*?[^/])'; |
920d6222 |
183 | # * -> capture path part |
184 | /\G\*/gc and |
185 | return '([^/]+)'; |
186 | } |
187 | return (); |
188 | } |
189 | |
190 | sub _url_extension_match { |
191 | my ($self, $str, $extension) = @_; |
c6ea9542 |
192 | if ($extension eq '*') { |
193 | sub { |
194 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) { |
195 | ({ PATH_INFO => $tmp }, $1); |
196 | } else { |
197 | (); |
198 | } |
199 | }; |
200 | } else { |
201 | sub { |
202 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) { |
203 | ({ PATH_INFO => $tmp }); |
204 | } else { |
205 | (); |
206 | } |
207 | }; |
208 | } |
920d6222 |
209 | } |
210 | |
9b9866ae |
211 | sub _parse_param_handler { |
212 | my ($self, $spec, $type) = @_; |
213 | |
214 | require Web::Simple::ParamParser; |
215 | my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from"); |
216 | |
217 | for ($_[1]) { |
218 | my (@required, @single, %multi, $star, $multistar) = @_; |
219 | PARAM: { do { |
220 | |
221 | # per param flag |
222 | |
223 | my $multi = 0; |
224 | |
225 | # ?@foo or ?@* |
226 | |
227 | /\G\@/gc and $multi = 1; |
228 | |
229 | # @* or * |
230 | |
231 | if (/\G\*/) { |
232 | |
233 | $multi ? ($multistar = 1) : ($star = 1); |
234 | } else { |
235 | |
236 | # @foo= or foo= or @foo~ or foo~ |
237 | |
238 | /\G(\w+)/gc or $self->_blam('Expected parameter name'); |
239 | |
240 | my $name = $1; |
241 | |
242 | # check for = or ~ on the end |
243 | |
244 | /\G\=/gc |
245 | ? push(@required, $name) |
246 | : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name')); |
247 | |
248 | # record the key in the right category depending on the multi (@) flag |
249 | |
250 | $multi ? (push @single, $name) : ($multi{$name} = 1); |
251 | } |
252 | } while (/\G\&/gc) } |
253 | |
254 | return sub { |
255 | my $raw = $unpacker->($_[0]); |
256 | foreach my $name (@required) { |
257 | return unless exists $raw->{$name}; |
258 | } |
259 | my %p; |
260 | foreach my $name ( |
261 | @single, |
262 | ($star |
263 | ? (grep { !exists $multi{$_} } keys %$raw) |
264 | : () |
265 | ) |
266 | ) { |
267 | $p{$name} = $raw->{$name}->[-1] if exists $raw->{$name}; |
268 | } |
269 | foreach my $name ( |
270 | keys %multi, |
271 | ($multistar |
272 | ? (grep { !exists $p{$_} } keys %$raw) |
273 | : () |
274 | ) |
275 | ) { |
276 | $p{$name} = $raw->{$name}||[]; |
277 | } |
278 | return ({}, \%p); |
279 | }; |
280 | } |
281 | } |
282 | |
920d6222 |
283 | 1; |