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