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 $spec =~ s/\s+//g; # whitespace is not valid
33 return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
37 my ($self, $spec, $nested) = @_;
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 match_method($1);
94 return $self->_url_path_match($_);
99 return match_extension($1);
104 return $self->_parse_spec($_, pos);
109 return match_not($self->_parse_spec_section($_));
113 return $self->_parse_param_handler($_, 'query');
117 return $self->_parse_param_handler($_, 'body');
119 return; # () will trigger the blam in our caller
122 sub _url_path_match {
128 PATH: while (/\G\//gc) {
134 push @path, $self->_url_path_segment_match($_)
135 or $self->_blam("Couldn't parse path match segment");
142 if (@path && !$end && !$keep_dot) {
143 length and $_ .= '(?:\.\w+)?' for $path[-1];
145 my $re = '^('.join('/','',@path).')'.$end.'$';
148 return match_path_strip($re);
150 return match_path($re);
156 sub _url_path_segment_match {
159 # trailing / -> require / on end of URL
160 /\G(?:(?=[+|\)])|$)/gc and
162 # word chars only -> exact path part match
165 # ** -> capture unlimited path parts
168 # * -> capture path part
175 sub _parse_param_handler {
176 my ($self, $spec, $type) = @_;
179 my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
186 my $is_kw = /\G\:/gc;
190 my $multi = /\G\@/gc;
196 $self->_blam("* is always named; no need to supply :") if $is_kw;
199 $self->_blam("Can only use one * or \@* in a parameter match");
202 $spec{star} = { multi => $multi };
205 # @foo= or foo= or @foo~ or foo~
207 /\G(\w+)/gc or $self->_blam('Expected parameter name');
211 # check for = or ~ on the end
214 ? push(@{$spec{required}||=[]}, $name)
215 : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
217 # record positional or keyword
219 push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
220 { name => $name, multi => $multi };
224 return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);