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).'^';
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 local $self->{already_have};
26 /^\G\s*/; # eat leading whitespace
28 push @match, $self->_parse_spec_section($_)
29 or $self->_blam("Unable to work out what the next section is");
31 $self->_blam("Found closing ) with no opening (") unless $nested;
34 last PARSE if (pos == length);
35 $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
36 or $self->_blam('No valid combinator - expected + or |');
37 } until (pos == length) }; # accept trailing whitespace
38 if ($nested and pos == length) {
40 $self->_blam("No closing ) found for opening (");
42 return $match[0] if (@match == 1);
44 my $env = { %{$_[0]} };
47 foreach my $match (@match) {
48 if (my @this_got = $match->($env)) {
49 my %change_env = %{shift(@this_got)};
50 @{$env}{keys %change_env} = values %change_env;
51 @{$new_env}{keys %change_env} = values %change_env;
57 return ($new_env, @got);
63 my ($self, $type) = @_;
64 $self->_blam("Can't have more than one ${type} match in a specification")
65 if $self->{already_have}{$type};
66 $self->{already_have}{$type} = 1;
69 sub _parse_spec_section {
73 # GET POST PUT HEAD ...
76 return $self->_http_method_match($_, $1);
81 return $self->_url_path_match($_);
86 return $self->_url_extension_match($_, $1);
91 return $self->_parse_spec($_, pos);
93 return; # () will trigger the blam in our caller
96 sub _parse_spec_combinator {
97 my ($self, $spec, $match) = @_;
107 local $self->{already_have};
108 push @match, $self->_parse_spec_section($_)
109 or $self->_blam("Unable to work out what the next section is");
110 last PARSE if (pos == length);
111 last PARSE unless /\G\|/gc; # give up when next thing isn't |
112 } until (pos == length) }; # accept trailing whitespace
114 foreach my $try (@match) {
115 if (my @ret = $try->(@_)) {
126 sub _http_method_match {
127 my ($self, $str, $method) = @_;
128 $self->_dupe_check('method');
129 sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
132 sub _url_path_match {
134 $self->_dupe_check('path');
138 push @path, $self->_url_path_segment_match($_)
139 or $self->_blam("Couldn't parse path match segment");
141 my $re = '^()'.join('/','',@path).'$';
143 if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
144 $cap[0] = {}; return @cap;
152 sub _url_path_segment_match {
155 # trailing / -> require / on end of URL
156 /\G(?:(?=\s)|$)/gc and
158 # word chars only -> exact path part match
161 # ** -> capture unlimited path parts
164 # * -> capture path part
171 sub _url_extension_match {
172 my ($self, $str, $extension) = @_;
173 $self->_dupe_check('extension');
174 if ($extension eq '*') {
176 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
177 ({ PATH_INFO => $tmp }, $1);
184 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
185 ({ PATH_INFO => $tmp });