factor out and simplify param parsing logic

diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm
index a4c2640..2e2afba 100644 (file)
--- a/lib/Web/Dispatch/Parser.pm
+++ b/lib/Web/Dispatch/Parser.pm
@@ -174,6 +174,7 @@ sub _parse_param_handler {
 
   for ($_[1]) {
     my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
+    my %spec;
     my $pos_idx = 0;
     PARAM: { do {
 
@@ -191,13 +192,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~
@@ -209,57 +208,19 @@ 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);
+      Web::Dispatch::Predicates::_extract_params($raw, \%spec);
     };
   }
 }

diff --git a/lib/Web/Dispatch/Predicates.pm b/lib/Web/Dispatch/Predicates.pm
index f47605b..432058c 100644 (file)
--- a/lib/Web/Dispatch/Predicates.pm
+++ b/lib/Web/Dispatch/Predicates.pm
@@ -101,4 +101,36 @@ sub match_extension {
   };
 }
 
+sub _extract_params {
+  my ($raw, $spec) = @_;
+  foreach my $name (@{$spec->{required}||[]}) {
+    return unless exists $raw->{$name};
+  }
+  my @ret = (
+    {},
+    map {
+      $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
+    } @{$spec->{positional}||[]}
+  );
+  # separated since 'or' is short circuit
+  my ($named, $star) = ($spec->{named}, $spec->{star});
+  if ($named or $star) {
+    my %kw;
+    if ($star) {
+      @kw{keys %$raw} = (
+        $star->{multi}
+          ? values %$raw
+          : map $_->[-1], values %$raw
+      );
+    }
+    foreach my $n (@{$named||[]}) {
+      next if !$n->{multi} and !exists $raw->{$n->{name}};
+      $kw{$n->{name}} = 
+        $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
+    }
+    push @ret, \%kw;
+  }
+  @ret;
+}
+
 1;

diff --git a/t/dispatch_parser.t b/t/dispatch_parser.t
index 503a570..caa4e45 100644 (file)
--- a/t/dispatch_parser.t
+++ b/t/dispatch_parser.t
@@ -315,7 +315,7 @@ foreach my $win (
     [ '?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
     [ '?*' => \%all_single ],
     [ '?@*' => \%all_multi ],
-    [ '?foo=&@*' => 'FOO', do { my %h = %all_multi; delete $h{foo}; \%h } ],
+    [ '?foo=&@*' => 'FOO', \%all_multi ],
     [ '?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
     [ '?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 ) {
@@ -366,7 +366,7 @@ foreach my $win2 (
     [ '/foo/bar/+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
     [ '/foo/bar/+?*' => \%all_single ],
     [ '/foo/bar/+?@*' => \%all_multi ],
-    [ '/foo/bar/+?foo=&@*' => 'FOO', do { my %h = %all_multi; delete $h{foo}; \%h } ],
+    [ '/foo/bar/+?foo=&@*' => 'FOO', \%all_multi ],
     [ '/foo/bar/+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
     [ '/foo/bar/+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 ) {
@@ -417,7 +417,7 @@ foreach my $win3 (
     [ '/foo/bar+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
     [ '/foo/bar+?*' => \%all_single ],
     [ '/foo/bar+?@*' => \%all_multi ],
-    [ '/foo/bar+?foo=&@*' => 'FOO', do { my %h = %all_multi; delete $h{foo}; \%h } ],
+    [ '/foo/bar+?foo=&@*' => 'FOO', \%all_multi ],
     [ '/foo/bar+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
     [ '/foo/bar+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 ) {