1 package Web::Dispatch::Parser;
6 if ($ENV{WEB_DISPATCH_PARSER_DEBUG}) {
7 no warnings 'redefine';
13 use Web::Dispatch::Predicates;
17 is => 'lazy', default => quote_sub q{ {} }
20 sub diag { if (DEBUG) { warn $_[0] } }
23 my ($self, $error) = @_;
24 my $hat = (' ' x (pos||0)).'^';
25 warn "Warning parsing dispatch specification: ${error}\n
31 my ($self, $error) = @_;
32 my $hat = (' ' x (pos||0)).'^';
33 die "Error parsing dispatch specification: ${error}\n
39 my ($self, $spec) = @_;
40 $spec =~ s/\s+//g; # whitespace is not valid
41 return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
45 my ($self, $spec, $nested) = @_;
46 return match_true() unless length($spec);
51 push @match, $self->_parse_spec_section($_)
52 or $self->_blam("Unable to work out what the next section is");
54 $self->_blam("Found closing ) with no opening (") unless $nested;
58 last PARSE if (pos == length);
59 $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
60 or $self->_blam('No valid combinator - expected + or |');
61 } until (pos == length) }; # accept trailing whitespace
62 if (!$close and $nested and pos == length) {
64 $self->_blam("No closing ) found for opening (");
66 return $match[0] if (@match == 1);
67 return match_and(@match);
71 sub _parse_spec_combinator {
72 my ($self, $spec, $match) = @_;
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
87 return match_or(@match);
93 sub _parse_spec_section {
100 return match_path('^$');
102 # GET POST PUT HEAD ...
105 return match_method($1);
110 return $self->_url_path_match($_);
115 return match_extension($1);
120 return $self->_parse_spec($_, pos);
125 return match_not($self->_parse_spec_section($_));
129 return $self->_parse_param_handler($_, 'query');
133 return $self->_parse_param_handler($_, 'body');
137 return $self->_parse_param_handler($_, 'uploads');
139 return; # () will trigger the blam in our caller
142 sub _url_path_match {
145 my (@path, @names, $seen_nameless);
148 PATH: while (/\G\//gc) {
155 my ($segment) = $self->_url_path_segment_match($_)
156 or $self->_blam("Couldn't parse path match 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")
165 $self->_blam("Can't mix positional and named captures in path match")
170 push @path, $segment;
180 last PATH if $keep_dot;
182 if (@path && !$end && !$keep_dot) {
183 length and $_ .= '(?:\.\w+)?' for $path[-1];
185 my $re = '^('.join('/','',@path).')'.$end.'$';
188 return match_path_strip($re, @names ? \@names : ());
190 return match_path($re, @names ? \@names : ());
196 sub _url_path_segment_match {
199 # trailing / -> require / on end of URL
200 /\G(?:(?=[+|\)])|$)/gc and
202 # word chars only -> exact path part match
205 (?: # start matching at a space followed by:
206 [\w\-] # word chars or dashes
209 (?!\.) # not followed by another period
211 + # then grab as far as possible
215 # ** -> capture unlimited path parts
216 /\G\*\*(?:(\.\*)?\:(\w+))?/gc and
217 return [ '(.*?[^/])', $1, $2 ];
218 # * -> capture path part
219 # *:name -> capture named path part
220 /\G\*(?:(\.\*)?\:(\w+))?/gc and
221 return [ '([^/]+?)', $1, $2 ];
223 # :name -> capture named path part
225 return [ '([^/]+?)', 0, $1 ];
230 sub _parse_param_handler {
231 my ($self, $spec, $type) = @_;
234 my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
241 my $is_kw = /\G\:/gc;
245 my $multi = /\G\@/gc;
251 $self->_blam("* is always named; no need to supply :") if $is_kw;
254 $self->_blam("Can only use one * or \@* in a parameter match");
257 $spec{star} = { multi => $multi };
260 # @foo= or foo= or @foo~ or foo~
262 /\G([\w.]*)/gc or $self->_blam('Expected parameter name');
266 # check for = or ~ on the end
269 ? push(@{$spec{required}||=[]}, $name)
270 : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
272 # record positional or keyword
274 push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
275 { name => $name, multi => $multi };
279 return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);