sub parse_dispatch_specification {
my ($self, $spec) = @_;
- for ($spec) {
+ return $self->_parse_spec($spec);
+}
+
+sub _parse_spec {
+ my ($self, $spec) = @_;
+ for ($_[1]) {
my @match;
local $self->{already_have};
/^\G\s*/; # eat leading whitespace
PARSE: { do {
- push @match, $self->_parse_spec_section($spec)
+ push @match, $self->_parse_spec_section($_)
or $self->_blam("Unable to work out what the next section is");
last PARSE if (pos == length);
- /\G\+/gc or $self->_blam('Spec sections must be separated by +');
+ $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
+ or $self->_blam('No valid combinator - expected + or |');
} until (pos == length) }; # accept trailing whitespace
return $match[0] if (@match == 1);
return sub {
/\G(?=\/)/gc and
return $self->_url_path_match($_);
- /\G\.(\w+)/gc and
+ # .* and .html
+
+ /\G\.(\*|\w+)/gc and
return $self->_url_extension_match($_, $1);
}
return; # () will trigger the blam in our caller
}
+sub _parse_spec_combinator {
+ my ($self, $spec, $match) = @_;
+ for ($_[1]) {
+
+ /\G\+/gc and
+ return $match;
+
+ /\G\|/gc and
+ return do {
+ my @match = $match;
+ PARSE: { do {
+ local $self->{already_have};
+ push @match, $self->_parse_spec_section($_)
+ or $self->_blam("Unable to work out what the next section is");
+ last PARSE if (pos == length);
+ last PARSE unless /\G\|/gc; # give up when next thing isn't |
+ } until (pos == length) }; # accept trailing whitespace
+ return sub {
+ foreach my $try (@match) {
+ if (my @ret = $try->(@_)) {
+ return @ret;
+ }
+ }
+ return;
+ };
+ };
+ }
+ return;
+}
+
sub _http_method_match {
my ($self, $str, $method) = @_;
$self->_dupe_check('method');
sub _url_extension_match {
my ($self, $str, $extension) = @_;
$self->_dupe_check('extension');
- sub {
- if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
- ({ PATH_INFO => $tmp });
- } else {
- ();
- }
- };
+ if ($extension eq '*') {
+ sub {
+ if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
+ ({ PATH_INFO => $tmp }, $1);
+ } else {
+ ();
+ }
+ };
+ } else {
+ sub {
+ if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
+ ({ PATH_INFO => $tmp });
+ } else {
+ ();
+ }
+ };
+ }
}
1;
'.xml does not match .html'
);
+my $any_ext = $dp->parse_dispatch_specification('.*');
+
+is_deeply(
+ [ $any_ext->({ PATH_INFO => '/foo/bar.html' }) ],
+ [ { PATH_INFO => '/foo/bar' }, 'html' ],
+ '.html matches .* and extension returned'
+);
+
+is_deeply(
+ [ $any_ext->({ PATH_INFO => '/foo/bar' }) ],
+ [],
+ 'no extension does not match .*'
+);
+
+
my $slash = $dp->parse_dispatch_specification('/');
is_deeply(
[],
'POST /post/one does not match'
);
+
+my $or = $dp->parse_dispatch_specification('GET|POST');
+
+foreach my $meth (qw(GET POST)) {
+
+ is_deeply(
+ [ $or->({ REQUEST_METHOD => $meth }) ],
+ [ {} ],
+ 'GET|POST matches method '.$meth
+ );
+}
+
+is_deeply(
+ [ $or->({ REQUEST_METHOD => 'PUT' }) ],
+ [],
+ 'GET|POST does not match PUT'
+);