basic named path part matching

diff --git a/Changes b/Changes
index 3ababd7..6a8d91e 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+  - Add named path matching
   - Allow headers on CLI calls
 
 0.013 - 2012-04-03

diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm
index 08ad342..6c2cea6 100644 (file)
--- a/lib/Web/Dispatch/Parser.pm
+++ b/lib/Web/Dispatch/Parser.pm
@@ -132,7 +132,7 @@ sub _parse_spec_section {
 sub _url_path_match {
   my ($self) = @_;
   for ($_[1]) {
-    my @path;
+    my (@path, @names, $seen_nameless);
     my $end = '';
     my $keep_dot;
     PATH: while (/\G\//gc) {
@@ -141,18 +141,33 @@ sub _url_path_match {
           $end = '(/.*)';
           last PATH;
         };
-      push @path, $self->_url_path_segment_match($_)
+
+      my ($segment) = $self->_url_path_segment_match($_)
         or $self->_blam("Couldn't parse path match segment");
+
+      if (ref($segment)) {
+        ($segment, $keep_dot, my $name) = @$segment;
+        if (defined($name)) {
+          $self->_blam("Can't mix positional and named captures in path match")
+            if $seen_nameless;
+          push @names, $name;
+        } else {
+          $self->_blam("Can't mix positional and named captures in path match")
+            if @names;
+          $seen_nameless = 1;
+        }
+      }
+      push @path, $segment;
+
       /\G\.\.\./gc
         and do {
           $end = '(|/.*)';
           last PATH;
         };
       /\G\.\*/gc
-        and do {
-          $keep_dot = 1;
-          last PATH;
-        };
+        and $keep_dot = 1;
+
+      last PATH if $keep_dot;
     }
     if (@path && !$end && !$keep_dot) {
       length and $_ .= '(?:\.\w+)?' for $path[-1];
@@ -160,9 +175,9 @@ sub _url_path_match {
     my $re = '^('.join('/','',@path).')'.$end.'$';
     $re = qr/$re/;
     if ($end) {
-      return match_path_strip($re);
+      return match_path_strip($re, @names ? \@names : ());
     } else {
-      return match_path($re);
+      return match_path($re, @names ? \@names : ());
     }
   }
   return;
@@ -188,11 +203,16 @@ sub _url_path_segment_match {
     /gcx and
       return "\Q$1";
     # ** -> capture unlimited path parts
-    /\G\*\*/gc and
-      return '(.*?[^/])';
+    /\G\*\*(?:(\.\*)?\:(\w+))?/gc and
+      return [ '(.*?[^/])', $1, $2 ];
     # * -> capture path part
-    /\G\*/gc and
-      return '([^/]+?)';
+    # *:name -> capture named path part
+    /\G\*(?:(\.\*)?\:(\w+))?/gc and
+      return [ '([^/]+?)', $1, $2 ];
+
+    # :name -> capture named path part
+    /\G\:(\w+)/gc and
+      return [ '([^/]+?)', 0, $1 ];
   }
   return ();
 }

diff --git a/lib/Web/Dispatch/Predicates.pm b/lib/Web/Dispatch/Predicates.pm
index 452a5e2..ab44055 100644 (file)
--- a/lib/Web/Dispatch/Predicates.pm
+++ b/lib/Web/Dispatch/Predicates.pm
@@ -71,18 +71,20 @@ sub match_method {
 }
 
 sub match_path {
-  my ($re) = @_;
+  my ($re, $names) = @_;
   _matcher(sub {
     my ($env) = @_;
     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
-      $cap[0] = {}; return @cap;
+      $cap[0] = {};
+      $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names;
+      return @cap;
     }
     return;
   })
 }
 
 sub match_path_strip {
-  my ($re) = @_;
+  my ($re, $names) = @_;
   _matcher(sub {
     my ($env) = @_;
     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
@@ -90,6 +92,7 @@ sub match_path_strip {
         SCRIPT_NAME => ($env->{SCRIPT_NAME}||'').$cap[0],
         PATH_INFO => pop(@cap),
       };
+      $cap[1] = do { my %c; @c{@$names} = splice @cap, 1; \%c } if $names;
       return @cap;
     }
     return;

diff --git a/t/dispatch_parser.t b/t/dispatch_parser.t
index 6cfcb9e..7b1632b 100644 (file)
--- a/t/dispatch_parser.t
+++ b/t/dispatch_parser.t
@@ -370,6 +370,24 @@ my $dp = Web::Dispatch::Parser->new;
   }
 }
 
+{
+  my @named = (
+    [ '/foo/*:foo_id' => '/foo/1' => { foo_id => 1 } ],
+    [ '/foo/:foo_id' => '/foo/1' => { foo_id => 1 } ],
+    [ '/foo/:id/**:rest' => '/foo/id/rest/of/the/path.ext'
+      => { id => 'id', rest => 'rest/of/the/path' } ],
+    [ '/foo/:id/**.*:rest' => '/foo/id/rest/of/the/path.ext'
+      => { id => 'id', rest => 'rest/of/the/path.ext' } ],
+  );
+  foreach my $n (@named) {
+    is_deeply(
+      [ $dp->parse($n->[0])->({ PATH_INFO => $n->[1] }) ],
+      [ {}, $n->[2] ],
+      "${\$n->[0]} matches ${\$n->[1]} with correct captures"
+    );
+  }
+}
+
 #
 # query string
 #