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 die "Error parsing dispatch specification: ${error}\n
31 my ($self, $spec) = @_;
32 return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
36 my ($self, $spec, $nested) = @_;
39 /^\G\s*/; # eat leading whitespace
41 push @match, $self->_parse_spec_section($_)
42 or $self->_blam("Unable to work out what the next section is");
44 $self->_blam("Found closing ) with no opening (") unless $nested;
47 last PARSE if (pos == length);
48 $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
49 or $self->_blam('No valid combinator - expected + or |');
50 } until (pos == length) }; # accept trailing whitespace
51 if ($nested and pos == length) {
53 $self->_blam("No closing ) found for opening (");
55 return $match[0] if (@match == 1);
56 return match_and(@match);
60 sub _parse_spec_combinator {
61 my ($self, $spec, $match) = @_;
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
76 return match_or(@match);
82 sub _parse_spec_section {
86 # GET POST PUT HEAD ...
89 return $self->_http_method_match($_, $1);
94 return $self->_url_path_match($_);
99 return $self->_url_extension_match($_, $1);
104 return $self->_parse_spec($_, pos);
110 my $match = $self->_parse_spec_section($_);
112 return {} unless $match->(@_);
119 return $self->_parse_param_handler($_, 'query');
123 return $self->_parse_param_handler($_, 'body');
125 return; # () will trigger the blam in our caller
128 sub _http_method_match {
129 my ($self, $str, $method) = @_;
130 match_method($method);
133 sub _url_path_match {
138 PATH: while (/\G\//gc) {
144 push @path, $self->_url_path_segment_match($_)
145 or $self->_blam("Couldn't parse path match segment");
147 my $re = '^('.join('/','',@path).')'.($full_path ? '$' : '(/.*)$');
150 return match_path($re);
152 return match_path_strip($re);
157 sub _url_path_segment_match {
160 # trailing / -> require / on end of URL
161 /\G(?:(?=[+|\)])|$)/gc and
163 # word chars only -> exact path part match
166 # ** -> capture unlimited path parts
169 # * -> capture path part
176 sub _url_extension_match {
177 my ($self, $str, $extension) = @_;
178 if ($extension eq '*') {
180 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
181 ({ PATH_INFO => $tmp }, $1);
188 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
189 ({ PATH_INFO => $tmp });
197 sub _parse_param_handler {
198 my ($self, $spec, $type) = @_;
200 require Web::Simple::ParamParser;
201 my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
204 my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
210 my $is_kw = /\G\:/gc;
214 my $multi = /\G\@/gc;
220 $self->_blam("* is always named; no need to supply :") if $is_kw;
222 $multi ? ($multistar = 1) : ($star = 1);
226 if ($star && $multistar) {
227 $self->_blam("Can't use * and \@* in the same parameter match");
231 # @foo= or foo= or @foo~ or foo~
233 /\G(\w+)/gc or $self->_blam('Expected parameter name');
237 # check for = or ~ on the end
240 ? push(@required, $name)
241 : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
243 # record the key in the right category depending on the multi (@) flag
245 $multi ? ($multi{$name} = 1) : (push @single, $name);
247 # record positional or keyword
249 $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
254 my $raw = $unpacker->($_[0]);
255 foreach my $name (@required) {
256 return unless exists $raw->{$name};
259 my @p = (undef) x $pos_idx;
263 ? (grep { !exists $multi{$_} } keys %$raw)
267 if (exists $raw->{$name}) {
268 if (exists $positional{$name}) {
269 $p[$positional{$name}] = $raw->{$name}->[-1];
271 $p{$name} = $raw->{$name}->[-1];
279 ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
283 if (exists $positional{$name}) {
284 $p[$positional{$name}] = $raw->{$name}||[];
286 $p{$name} = $raw->{$name}||[];
289 $p[$pos_idx] = \%p if $have_kw;