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 | |
63753442 |
22 | sub _wtf { |
23 | my ($self, $error) = @_; |
24 | my $hat = (' ' x (pos||0)).'^'; |
25 | warn "Warning parsing dispatch specification: ${error}\n |
26 | ${_} |
27 | ${hat} here\n"; |
28 | } |
29 | |
920d6222 |
30 | sub _blam { |
31 | my ($self, $error) = @_; |
a4ec359d |
32 | my $hat = (' ' x (pos||0)).'^'; |
920d6222 |
33 | die "Error parsing dispatch specification: ${error}\n |
34 | ${_} |
35 | ${hat} here\n"; |
36 | } |
37 | |
d63bcdae |
38 | sub parse { |
920d6222 |
39 | my ($self, $spec) = @_; |
69aaa28a |
40 | $spec =~ s/\s+//g; # whitespace is not valid |
d63bcdae |
41 | return $self->_cache->{$spec} ||= $self->_parse_spec($spec); |
c6ea9542 |
42 | } |
43 | |
44 | sub _parse_spec { |
b0420ad6 |
45 | my ($self, $spec, $nested) = @_; |
bc878dde |
46 | return match_true() unless length($spec); |
c6ea9542 |
47 | for ($_[1]) { |
920d6222 |
48 | my @match; |
63753442 |
49 | my $close; |
920d6222 |
50 | PARSE: { do { |
c6ea9542 |
51 | push @match, $self->_parse_spec_section($_) |
920d6222 |
52 | or $self->_blam("Unable to work out what the next section is"); |
b0420ad6 |
53 | if (/\G\)/gc) { |
54 | $self->_blam("Found closing ) with no opening (") unless $nested; |
63753442 |
55 | $close = 1; |
b0420ad6 |
56 | last PARSE; |
57 | } |
920d6222 |
58 | last PARSE if (pos == length); |
c6ea9542 |
59 | $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) |
60 | or $self->_blam('No valid combinator - expected + or |'); |
920d6222 |
61 | } until (pos == length) }; # accept trailing whitespace |
63753442 |
62 | if (!$close and $nested and pos == length) { |
a4ec359d |
63 | pos = $nested - 1; |
b0420ad6 |
64 | $self->_blam("No closing ) found for opening ("); |
65 | } |
920d6222 |
66 | return $match[0] if (@match == 1); |
d63bcdae |
67 | return match_and(@match); |
920d6222 |
68 | } |
69 | } |
70 | |
9b9866ae |
71 | sub _parse_spec_combinator { |
72 | my ($self, $spec, $match) = @_; |
73 | for ($_[1]) { |
74 | |
75 | /\G\+/gc and |
76 | return $match; |
77 | |
78 | /\G\|/gc and |
79 | return do { |
80 | my @match = $match; |
81 | PARSE: { do { |
82 | push @match, $self->_parse_spec_section($_) |
83 | or $self->_blam("Unable to work out what the next section is"); |
84 | last PARSE if (pos == length); |
85 | last PARSE unless /\G\|/gc; # give up when next thing isn't | |
86 | } until (pos == length) }; # accept trailing whitespace |
d63bcdae |
87 | return match_or(@match); |
9b9866ae |
88 | }; |
89 | } |
90 | return; |
91 | } |
92 | |
920d6222 |
93 | sub _parse_spec_section { |
94 | my ($self) = @_; |
95 | for ($_[1]) { |
96 | |
a96dd5cb |
97 | # ~ |
98 | |
99 | /\G~/gc and |
100 | return match_path('^$'); |
101 | |
920d6222 |
102 | # GET POST PUT HEAD ... |
103 | |
104 | /\G([A-Z]+)/gc and |
e954644c |
105 | return match_method($1); |
920d6222 |
106 | |
107 | # /... |
108 | |
109 | /\G(?=\/)/gc and |
110 | return $self->_url_path_match($_); |
111 | |
c6ea9542 |
112 | # .* and .html |
113 | |
114 | /\G\.(\*|\w+)/gc and |
e954644c |
115 | return match_extension($1); |
b0420ad6 |
116 | |
2ee4ab06 |
117 | # (...) |
b0420ad6 |
118 | |
119 | /\G\(/gc and |
120 | return $self->_parse_spec($_, pos); |
2ee4ab06 |
121 | |
122 | # !something |
123 | |
124 | /\G!/gc and |
ce573717 |
125 | return match_not($self->_parse_spec_section($_)); |
920d6222 |
126 | |
9b9866ae |
127 | # ?<param spec> |
128 | /\G\?/gc and |
129 | return $self->_parse_param_handler($_, 'query'); |
53d47b78 |
130 | |
131 | # %<param spec> |
132 | /\G\%/gc and |
133 | return $self->_parse_param_handler($_, 'body'); |
05aafc1a |
134 | |
135 | # *<param spec> |
136 | /\G\*/gc and |
137 | return $self->_parse_param_handler($_, 'uploads'); |
c6ea9542 |
138 | } |
9b9866ae |
139 | return; # () will trigger the blam in our caller |
c6ea9542 |
140 | } |
141 | |
920d6222 |
142 | sub _url_path_match { |
143 | my ($self) = @_; |
920d6222 |
144 | for ($_[1]) { |
b83ac307 |
145 | my (@path, @names, $seen_nameless); |
e7dd1c4b |
146 | my $end = ''; |
15e679c1 |
147 | my $keep_dot; |
da8429c9 |
148 | PATH: while (/\G\//gc) { |
149 | /\G\.\.\./gc |
150 | and do { |
e7dd1c4b |
151 | $end = '(/.*)'; |
da8429c9 |
152 | last PATH; |
153 | }; |
b83ac307 |
154 | |
155 | my ($segment) = $self->_url_path_segment_match($_) |
920d6222 |
156 | or $self->_blam("Couldn't parse path match segment"); |
b83ac307 |
157 | |
158 | if (ref($segment)) { |
159 | ($segment, $keep_dot, my $name) = @$segment; |
160 | if (defined($name)) { |
161 | $self->_blam("Can't mix positional and named captures in path match") |
162 | if $seen_nameless; |
163 | push @names, $name; |
164 | } else { |
165 | $self->_blam("Can't mix positional and named captures in path match") |
166 | if @names; |
167 | $seen_nameless = 1; |
168 | } |
169 | } |
170 | push @path, $segment; |
171 | |
8c51c01a |
172 | /\G\.\.\./gc |
173 | and do { |
bb0dbe7c |
174 | $end = '(|/.*)'; |
8c51c01a |
175 | last PATH; |
176 | }; |
15e679c1 |
177 | /\G\.\*/gc |
b83ac307 |
178 | and $keep_dot = 1; |
179 | |
180 | last PATH if $keep_dot; |
920d6222 |
181 | } |
15e679c1 |
182 | if (@path && !$end && !$keep_dot) { |
4ed4fb42 |
183 | length and $_ .= '(?:\.\w+)?' for $path[-1]; |
184 | } |
e7dd1c4b |
185 | my $re = '^('.join('/','',@path).')'.$end.'$'; |
da8429c9 |
186 | $re = qr/$re/; |
e7dd1c4b |
187 | if ($end) { |
b83ac307 |
188 | return match_path_strip($re, @names ? \@names : ()); |
e7dd1c4b |
189 | } else { |
b83ac307 |
190 | return match_path($re, @names ? \@names : ()); |
da8429c9 |
191 | } |
920d6222 |
192 | } |
193 | return; |
194 | } |
195 | |
196 | sub _url_path_segment_match { |
197 | my ($self) = @_; |
198 | for ($_[1]) { |
199 | # trailing / -> require / on end of URL |
6c0f599a |
200 | /\G(?:(?=[+|\)])|$)/gc and |
e7dd1c4b |
201 | return ''; |
920d6222 |
202 | # word chars only -> exact path part match |
c2cf0534 |
203 | / |
204 | \G( |
205 | (?: # start matching at a space followed by: |
206 | [\w\-] # word chars or dashes |
207 | | # OR |
208 | \. # a period |
209 | (?!\.) # not followed by another period |
210 | ) |
211 | + # then grab as far as possible |
212 | ) |
213 | /gcx and |
920d6222 |
214 | return "\Q$1"; |
28f3dfd5 |
215 | # ** -> capture unlimited path parts |
b83ac307 |
216 | /\G\*\*(?:(\.\*)?\:(\w+))?/gc and |
217 | return [ '(.*?[^/])', $1, $2 ]; |
920d6222 |
218 | # * -> capture path part |
b83ac307 |
219 | # *:name -> capture named path part |
220 | /\G\*(?:(\.\*)?\:(\w+))?/gc and |
221 | return [ '([^/]+?)', $1, $2 ]; |
222 | |
223 | # :name -> capture named path part |
224 | /\G\:(\w+)/gc and |
225 | return [ '([^/]+?)', 0, $1 ]; |
920d6222 |
226 | } |
227 | return (); |
228 | } |
229 | |
9b9866ae |
230 | sub _parse_param_handler { |
231 | my ($self, $spec, $type) = @_; |
232 | |
9b9866ae |
233 | for ($_[1]) { |
eb9e0e25 |
234 | my (@required, @single, %multi, $star, $multistar, %positional, $have_kw); |
052bdd54 |
235 | my %spec; |
eb9e0e25 |
236 | my $pos_idx = 0; |
9b9866ae |
237 | PARAM: { do { |
238 | |
eb9e0e25 |
239 | # ?:foo or ?@:foo |
9b9866ae |
240 | |
eb9e0e25 |
241 | my $is_kw = /\G\:/gc; |
9b9866ae |
242 | |
243 | # ?@foo or ?@* |
244 | |
eb9e0e25 |
245 | my $multi = /\G\@/gc; |
9b9866ae |
246 | |
247 | # @* or * |
248 | |
a5917caa |
249 | if (/\G\*/gc) { |
9b9866ae |
250 | |
eb9e0e25 |
251 | $self->_blam("* is always named; no need to supply :") if $is_kw; |
252 | |
052bdd54 |
253 | if ($star) { |
254 | $self->_blam("Can only use one * or \@* in a parameter match"); |
a5917caa |
255 | } |
052bdd54 |
256 | |
257 | $spec{star} = { multi => $multi }; |
9b9866ae |
258 | } else { |
259 | |
260 | # @foo= or foo= or @foo~ or foo~ |
6c0f599a |
261 | |
0cddee76 |
262 | /\G([\w.]*)/gc or $self->_blam('Expected parameter name'); |
9b9866ae |
263 | |
264 | my $name = $1; |
265 | |
266 | # check for = or ~ on the end |
267 | |
268 | /\G\=/gc |
052bdd54 |
269 | ? push(@{$spec{required}||=[]}, $name) |
9b9866ae |
270 | : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name')); |
271 | |
eb9e0e25 |
272 | # record positional or keyword |
273 | |
052bdd54 |
274 | push @{$spec{$is_kw ? 'named' : 'positional'}||=[]}, |
275 | { name => $name, multi => $multi }; |
9b9866ae |
276 | } |
277 | } while (/\G\&/gc) } |
278 | |
b6bf9ed3 |
279 | return Web::Dispatch::Predicates->can("match_${type}")->(\%spec); |
9b9866ae |
280 | } |
281 | } |
282 | |
920d6222 |
283 | 1; |