1 package Web::Simple::DispatchParser;
4 use warnings FATAL => 'all';
9 if ($ENV{WEB_SIMPLE_DISPATCHPARSER_DEBUG}) {
10 no warnings 'redefine';
15 sub diag { if (DEBUG) { warn $_[0] } }
17 sub new { bless({}, ref($_[0])||$_[0]) }
20 my ($self, $error) = @_;
21 my $hat = (' ' x (pos||0)).'^';
22 die "Error parsing dispatch specification: ${error}\n
27 sub parse_dispatch_specification {
28 my ($self, $spec) = @_;
29 return $self->_parse_spec($spec);
33 my ($self, $spec, $nested) = @_;
36 /^\G\s*/; # eat leading whitespace
38 push @match, $self->_parse_spec_section($_)
39 or $self->_blam("Unable to work out what the next section is");
41 $self->_blam("Found closing ) with no opening (") unless $nested;
44 last PARSE if (pos == length);
45 $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
46 or $self->_blam('No valid combinator - expected + or |');
47 } until (pos == length) }; # accept trailing whitespace
48 if ($nested and pos == length) {
50 $self->_blam("No closing ) found for opening (");
52 return $match[0] if (@match == 1);
54 my $env = { %{$_[0]} };
57 foreach my $match (@match) {
58 if (my @this_got = $match->($env)) {
59 my %change_env = %{shift(@this_got)};
60 @{$env}{keys %change_env} = values %change_env;
61 @{$new_env}{keys %change_env} = values %change_env;
67 return ($new_env, @got);
72 sub _parse_spec_combinator {
73 my ($self, $spec, $match) = @_;
83 push @match, $self->_parse_spec_section($_)
84 or $self->_blam("Unable to work out what the next section is");
85 last PARSE if (pos == length);
86 last PARSE unless /\G\|/gc; # give up when next thing isn't |
87 } until (pos == length) }; # accept trailing whitespace
89 foreach my $try (@match) {
90 if (my @ret = $try->(@_)) {
101 sub _parse_spec_section {
105 # GET POST PUT HEAD ...
108 return $self->_http_method_match($_, $1);
113 return $self->_url_path_match($_);
118 return $self->_url_extension_match($_, $1);
123 return $self->_parse_spec($_, pos);
129 my $match = $self->_parse_spec_section($_);
131 return {} unless $match->(@_);
138 return $self->_parse_param_handler($_, 'query');
142 return $self->_parse_param_handler($_, 'body');
144 return; # () will trigger the blam in our caller
147 sub _http_method_match {
148 my ($self, $str, $method) = @_;
149 sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
152 sub _url_path_match {
157 PATH: while (/\G\//gc) {
163 push @path, $self->_url_path_segment_match($_)
164 or $self->_blam("Couldn't parse path match segment");
166 my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$');
170 if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
171 $cap[0] = {}; return @cap;
177 if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
178 $cap[0] = { PATH_INFO => pop(@cap) }; return @cap;
186 sub _url_path_segment_match {
189 # trailing / -> require / on end of URL
190 /\G(?:(?=\s)|$)/gc and
192 # word chars only -> exact path part match
195 # ** -> capture unlimited path parts
198 # * -> capture path part
205 sub _url_extension_match {
206 my ($self, $str, $extension) = @_;
207 if ($extension eq '*') {
209 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
210 ({ PATH_INFO => $tmp }, $1);
217 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
218 ({ PATH_INFO => $tmp });
226 sub _parse_param_handler {
227 my ($self, $spec, $type) = @_;
229 require Web::Simple::ParamParser;
230 my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
233 my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
239 my $is_kw = /\G\:/gc;
243 my $multi = /\G\@/gc;
249 $self->_blam("* is always named; no need to supply :") if $is_kw;
251 $multi ? ($multistar = 1) : ($star = 1);
255 if ($star && $multistar) {
256 $self->_blam("Can't use * and \@* in the same parameter match");
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(@required, $name)
270 : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
272 # record the key in the right category depending on the multi (@) flag
274 $multi ? ($multi{$name} = 1) : (push @single, $name);
276 # record positional or keyword
278 $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
283 my $raw = $unpacker->($_[0]);
284 foreach my $name (@required) {
285 return unless exists $raw->{$name};
288 my @p = (undef) x $pos_idx;
292 ? (grep { !exists $multi{$_} } keys %$raw)
296 if (exists $raw->{$name}) {
297 if (exists $positional{$name}) {
298 $p[$positional{$name}] = $raw->{$name}->[-1];
300 $p{$name} = $raw->{$name}->[-1];
308 ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
312 if (exists $positional{$name}) {
313 $p[$positional{$name}] = $raw->{$name}||[];
315 $p{$name} = $raw->{$name}||[];
318 $p[$pos_idx] = \%p if $have_kw;