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) = @_;
20 local $self->{already_have};
21 /^\G\s*/; # eat leading whitespace
23 push @match, $self->_parse_spec_section($spec)
24 or $self->_blam("Unable to work out what the next section is");
25 last PARSE if (pos == length);
26 /\G\+/gc or $self->_blam('Spec sections must be separated by +');
27 } until (pos == length) }; # accept trailing whitespace
28 return $match[0] if (@match == 1);
30 my $env = { %{$_[0]} };
33 foreach my $match (@match) {
34 if (my @this_got = $match->($env)) {
35 my %change_env = %{shift(@this_got)};
36 @{$env}{keys %change_env} = values %change_env;
37 @{$new_env}{keys %change_env} = values %change_env;
43 return ($new_env, @got);
49 my ($self, $type) = @_;
50 $self->_blam("Can't have more than one ${type} match in a specification")
51 if $self->{already_have}{$type};
52 $self->{already_have}{$type} = 1;
55 sub _parse_spec_section {
59 # GET POST PUT HEAD ...
62 return $self->_http_method_match($_, $1);
67 return $self->_url_path_match($_);
70 return $self->_url_extension_match($_, $1);
72 return; # () will trigger the blam in our caller
75 sub _http_method_match {
76 my ($self, $str, $method) = @_;
77 $self->_dupe_check('method');
78 sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
83 $self->_dupe_check('path');
87 push @path, $self->_url_path_segment_match($_)
88 or $self->_blam("Couldn't parse path match segment");
90 my $re = '^()'.join('/','',@path).'$';
92 if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
93 $cap[0] = {}; return @cap;
101 sub _url_path_segment_match {
104 # trailing / -> require / on end of URL
105 /\G(?:(?=\s)|$)/gc and
107 # word chars only -> exact path part match
110 # ** -> capture unlimited path parts
113 # * -> capture path part
120 sub _url_extension_match {
121 my ($self, $str, $extension) = @_;
122 $self->_dupe_check('extension');
124 if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
125 ({ PATH_INFO => $tmp });