1 package Web::Simple::DispatchParser;
4 use warnings FATAL => 'all';
6 sub new { bless({}, ref($_[0])||$_[0]) }
9 my ($self, $error) = @_;
10 my $hat = (' ' x (pos||0)).'^';
11 die "Error parsing dispatch specification: ${error}\n
16 sub parse_dispatch_specification {
17 my ($self, $spec) = @_;
18 return $self->_parse_spec($spec);
22 my ($self, $spec, $nested) = @_;
25 /^\G\s*/; # eat leading whitespace
27 push @match, $self->_parse_spec_section($_)
28 or $self->_blam("Unable to work out what the next section is");
30 $self->_blam("Found closing ) with no opening (") unless $nested;
33 last PARSE if (pos == length);
34 $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
35 or $self->_blam('No valid combinator - expected + or |');
36 } until (pos == length) }; # accept trailing whitespace
37 if ($nested and pos == length) {
39 $self->_blam("No closing ) found for opening (");
41 return $match[0] if (@match == 1);
43 my $env = { %{$_[0]} };
46 foreach my $match (@match) {
47 if (my @this_got = $match->($env)) {
48 my %change_env = %{shift(@this_got)};
49 @{$env}{keys %change_env} = values %change_env;
50 @{$new_env}{keys %change_env} = values %change_env;
56 return ($new_env, @got);
61 sub _parse_spec_combinator {
62 my ($self, $spec, $match) = @_;
72 push @match, $self->_parse_spec_section($_)
73 or $self->_blam("Unable to work out what the next section is");
74 last PARSE if (pos == length);
75 last PARSE unless /\G\|/gc; # give up when next thing isn't |
76 } until (pos == length) }; # accept trailing whitespace
78 foreach my $try (@match) {
79 if (my @ret = $try->(@_)) {
90 sub _parse_spec_section {
94 # GET POST PUT HEAD ...
97 return $self->_http_method_match($_, $1);
102 return $self->_url_path_match($_);
107 return $self->_url_extension_match($_, $1);
112 return $self->_parse_spec($_, pos);
118 my $match = $self->_parse_spec_section($_);
120 return {} unless $match->(@_);
127 return $self->_parse_param_handler($_, 'query');
129 return; # () will trigger the blam in our caller
132 sub _http_method_match {
133 my ($self, $str, $method) = @_;
134 sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
137 sub _url_path_match {
142 PATH: while (/\G\//gc) {
148 push @path, $self->_url_path_segment_match($_)
149 or $self->_blam("Couldn't parse path match segment");
151 my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$');
155 if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
156 $cap[0] = {}; return @cap;
162 if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
163 $cap[0] = { PATH_INFO => pop(@cap) }; return @cap;
171 sub _url_path_segment_match {
174 # trailing / -> require / on end of URL
175 /\G(?:(?=\s)|$)/gc and
177 # word chars only -> exact path part match
180 # ** -> capture unlimited path parts
183 # * -> capture path part
190 sub _url_extension_match {
191 my ($self, $str, $extension) = @_;
192 if ($extension eq '*') {
194 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
195 ({ PATH_INFO => $tmp }, $1);
202 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
203 ({ PATH_INFO => $tmp });
211 sub _parse_param_handler {
212 my ($self, $spec, $type) = @_;
214 require Web::Simple::ParamParser;
215 my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
218 my (@required, @single, %multi, $star, $multistar) = @_;
227 /\G\@/gc and $multi = 1;
233 $multi ? ($multistar = 1) : ($star = 1);
236 # @foo= or foo= or @foo~ or foo~
238 /\G(\w+)/gc or $self->_blam('Expected parameter name');
242 # check for = or ~ on the end
245 ? push(@required, $name)
246 : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
248 # record the key in the right category depending on the multi (@) flag
250 $multi ? (push @single, $name) : ($multi{$name} = 1);
255 my $raw = $unpacker->($_[0]);
256 foreach my $name (@required) {
257 return unless exists $raw->{$name};
263 ? (grep { !exists $multi{$_} } keys %$raw)
267 $p{$name} = $raw->{$name}->[-1] if exists $raw->{$name};
272 ? (grep { !exists $p{$_} } keys %$raw)
276 $p{$name} = $raw->{$name}||[];