X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FWeb%2FDispatch%2FParser.pm;h=6ebc51e4d64e0163b4d7bdf4be2d1ec91712fe67;hb=59ccc1e85596c73f96fce832d900fe72a764f230;hp=b731b17c636639d949fcc981077d04aba3fa9b57;hpb=4ed4fb42c2a30a541a4eae477c7ad35a81b39c30;p=catagits%2FWeb-Simple.git
diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm
index b731b17..6ebc51e 100644
--- a/lib/Web/Dispatch/Parser.pm
+++ b/lib/Web/Dispatch/Parser.pm
@@ -29,14 +29,15 @@ ${hat} here\n";
sub parse {
my ($self, $spec) = @_;
+ $spec =~ s/\s+//g; # whitespace is not valid
return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
}
sub _parse_spec {
my ($self, $spec, $nested) = @_;
+ return sub { {} } unless length($spec);
for ($_[1]) {
my @match;
- /^\G\s*/; # eat leading whitespace
PARSE: { do {
push @match, $self->_parse_spec_section($_)
or $self->_blam("Unable to work out what the next section is");
@@ -86,7 +87,7 @@ sub _parse_spec_section {
# GET POST PUT HEAD ...
/\G([A-Z]+)/gc and
- return $self->_http_method_match($_, $1);
+ return match_method($1);
# /...
@@ -96,7 +97,7 @@ sub _parse_spec_section {
# .* and .html
/\G\.(\*|\w+)/gc and
- return $self->_url_extension_match($_, $1);
+ return match_extension($1);
# (...)
@@ -106,13 +107,7 @@ sub _parse_spec_section {
# !something
/\G!/gc and
- return do {
- my $match = $self->_parse_spec_section($_);
- return sub {
- return {} unless $match->(@_);
- return;
- };
- };
+ return match_not($self->_parse_spec_section($_));
# ?
/\G\?/gc and
@@ -121,20 +116,20 @@ sub _parse_spec_section {
# %
/\G\%/gc and
return $self->_parse_param_handler($_, 'body');
+
+ # *
+ /\G\*/gc and
+ return $self->_parse_param_handler($_, 'uploads');
}
return; # () will trigger the blam in our caller
}
-sub _http_method_match {
- my ($self, $str, $method) = @_;
- match_method($method);
-}
-
sub _url_path_match {
my ($self) = @_;
for ($_[1]) {
my @path;
my $end = '';
+ my $keep_dot;
PATH: while (/\G\//gc) {
/\G\.\.\./gc
and do {
@@ -143,8 +138,13 @@ sub _url_path_match {
};
push @path, $self->_url_path_segment_match($_)
or $self->_blam("Couldn't parse path match segment");
+ /\G\.\*/gc
+ and do {
+ $keep_dot = 1;
+ last PATH;
+ };
}
- if (@path && !$end) {
+ if (@path && !$end && !$keep_dot) {
length and $_ .= '(?:\.\w+)?' for $path[-1];
}
my $re = '^('.join('/','',@path).')'.$end.'$';
@@ -165,7 +165,7 @@ sub _url_path_segment_match {
/\G(?:(?=[+|\)])|$)/gc and
return '';
# word chars only -> exact path part match
- /\G(\w+)/gc and
+ /\G([\w\-]+)/gc and
return "\Q$1";
# ** -> capture unlimited path parts
/\G\*\*/gc and
@@ -177,35 +177,12 @@ sub _url_path_segment_match {
return ();
}
-sub _url_extension_match {
- my ($self, $str, $extension) = @_;
- 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 {
- ();
- }
- };
- }
-}
-
sub _parse_param_handler {
my ($self, $spec, $type) = @_;
- require Web::Simple::ParamParser;
- my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
-
for ($_[1]) {
my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
+ my %spec;
my $pos_idx = 0;
PARAM: { do {
@@ -223,13 +200,11 @@ sub _parse_param_handler {
$self->_blam("* is always named; no need to supply :") if $is_kw;
- $multi ? ($multistar = 1) : ($star = 1);
-
- $have_kw = 1;
-
- if ($star && $multistar) {
- $self->_blam("Can't use * and \@* in the same parameter match");
+ if ($star) {
+ $self->_blam("Can only use one * or \@* in a parameter match");
}
+
+ $spec{star} = { multi => $multi };
} else {
# @foo= or foo= or @foo~ or foo~
@@ -241,58 +216,17 @@ sub _parse_param_handler {
# check for = or ~ on the end
/\G\=/gc
- ? push(@required, $name)
+ ? push(@{$spec{required}||=[]}, $name)
: (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
- # record the key in the right category depending on the multi (@) flag
-
- $multi ? ($multi{$name} = 1) : (push @single, $name);
-
# record positional or keyword
- $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
+ push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
+ { name => $name, multi => $multi };
}
} while (/\G\&/gc) }
- return sub {
- my $raw = $unpacker->($_[0]);
- foreach my $name (@required) {
- return unless exists $raw->{$name};
- }
- my (%p, %done);
- my @p = (undef) x $pos_idx;
- foreach my $name (
- @single,
- ($star
- ? (grep { !exists $multi{$_} } keys %$raw)
- : ()
- )
- ) {
- if (exists $raw->{$name}) {
- if (exists $positional{$name}) {
- $p[$positional{$name}] = $raw->{$name}->[-1];
- } else {
- $p{$name} = $raw->{$name}->[-1];
- }
- }
- $done{$name} = 1;
- }
- foreach my $name (
- keys %multi,
- ($multistar
- ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
- : ()
- )
- ) {
- if (exists $positional{$name}) {
- $p[$positional{$name}] = $raw->{$name}||[];
- } else {
- $p{$name} = $raw->{$name}||[];
- }
- }
- $p[$pos_idx] = \%p if $have_kw;
- return ({}, @p);
- };
+ return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);
}
}