enable matching of empty string specs

[catagits/Web-Simple.git] / lib / Web / Dispatch / Parser.pm

diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm
index 9d02af1..6ebc51e 100644 (file)
--- a/lib/Web/Dispatch/Parser.pm
+++ b/lib/Web/Dispatch/Parser.pm
@@ -35,6 +35,7 @@ sub parse {
 
 sub _parse_spec {
   my ($self, $spec, $nested) = @_;
+  return sub { {} } unless length($spec);
   for ($_[1]) {
     my @match;
     PARSE: { do {
@@ -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($_));
 
     # ?<param spec>
     /\G\?/gc and
@@ -121,20 +116,20 @@ sub _parse_spec_section {
     # %<param spec>
     /\G\%/gc and
       return $self->_parse_param_handler($_, 'body');
+
+    # *<param spec>
+    /\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.'$';
@@ -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);
   }
 }