From 0d186b000568db5d703a451f19fbeabf1f21918d Mon Sep 17 00:00:00 2001
From: Sam Crawley <samc@samc-pc.wgtn.cat-it.co.nz>
Date: Fri, 4 Jul 2014 17:30:47 +1200
Subject: [PATCH] Allow prefixes to be regexes or captures.

---
 lib/Dancer/App.pm                     |  2 +-
 lib/Dancer/Route.pm                   | 28 +++++++++++---
 t/03_route_handler/15_prefix_params.t | 55 +++++++++++++++++++++++++++
 3 files changed, 79 insertions(+), 6 deletions(-)
 create mode 100644 t/03_route_handler/15_prefix_params.t

diff --git a/lib/Dancer/App.pm b/lib/Dancer/App.pm
index 57dbfff81..704d60bcb 100644
--- a/lib/Dancer/App.pm
+++ b/lib/Dancer/App.pm
@@ -55,7 +55,7 @@ sub set_prefix {
     undef $prefix if defined($prefix) and $prefix eq "/";
 
     raise core_app => "not a valid prefix: `$prefix', must start with a /"
-      if defined($prefix) && $prefix !~ /^\//;
+      if defined($prefix) && ref $prefix ne 'Regexp' && $prefix !~ /^\//;
 
     my $app_prefix = defined $self->app_prefix ? $self->app_prefix : "";
     my $previous = Dancer::App->current->prefix;
diff --git a/lib/Dancer/Route.pm b/lib/Dancer/Route.pm
index 2a7f2c4e1..1f27b4297 100644
--- a/lib/Dancer/Route.pm
+++ b/lib/Dancer/Route.pm
@@ -44,7 +44,7 @@ sub init {
         unless defined $self->pattern;
 
     # If the route is a Regexp, store it directly
-    $self->regexp($self->pattern) 
+    $self->regexp($self->pattern)
       if ref($self->pattern) eq 'Regexp';
 
     $self->check_options();
@@ -273,19 +273,26 @@ sub _init_prefix {
         }
     }
     elsif ($self->pattern eq '/') {
-
         # if pattern is '/', we should match:
         # - /prefix/
         # - /prefix
         # this is done by creating a regex for this case
         my $qpattern = quotemeta( $self->pattern );
-        my $qprefix  = quotemeta( $self->prefix );
+        my ($qprefix, @params) = $self->_pattern_to_regex( $self->prefix );
         my $regex    = qr/^$qprefix(?:$qpattern)?$/;
+
         $self->{regexp}  = $regex;
         $self->{pattern} = $regex;
+        $self->{_params} = \@params if @params;
     }
     else {
         $self->{pattern} = $prefix . $self->pattern;
+
+        if ($prefix !~ m|^/|) {
+            # If the prefix doesn't start with /, we assume it's a
+            #  regex.
+            $self->regexp($self->{pattern});
+        }
     }
 
     return $prefix;
@@ -316,6 +323,18 @@ sub _build_regexp {
     return $self->{_compiled_regexp};
 }
 
+sub _pattern_to_regex {
+    my $self = shift;
+    my $pattern = shift;
+
+    my @params = $pattern =~ /:([^\/\.\?]+)/g;
+    if (@params) {
+        $pattern =~ s/(:[^\/\.\?]+)/\(\[\^\/\]\+\)/g;
+    }
+
+    return $pattern, @params;
+}
+
 sub _build_regexp_from_string {
     my ($self, $pattern) = @_;
     my $capture = 0;
@@ -323,9 +342,8 @@ sub _build_regexp_from_string {
 
     # look for route with params (/hello/:foo)
     if ($pattern =~ /:/) {
-        @params = $pattern =~ /:([^\/\.\?]+)/g;
+        ($pattern, @params) = $self->_pattern_to_regex($pattern);
         if (@params) {
-            $pattern =~ s/(:[^\/\.\?]+)/\(\[\^\/\]\+\)/g;
             $capture = 1;
         }
     }
diff --git a/t/03_route_handler/15_prefix_params.t b/t/03_route_handler/15_prefix_params.t
new file mode 100644
index 000000000..57e44cd0e
--- /dev/null
+++ b/t/03_route_handler/15_prefix_params.t
@@ -0,0 +1,55 @@
+use Test::More import => ['!pass'];
+use Dancer ':syntax';
+use Dancer::Test;
+use Dancer::Route;
+
+my @tests = (
+    { path => '/capture/test/foo',         expected => 'capture foo: test' },
+    { path => '/capture/test/',            expected => 'capture root: test' },
+    { path => '/capture/another_test',     expected => 'capture root: another_test' },
+
+    { path => '/regex/test2/bar',     expected => 'regex bar: test2' },
+    { path => '/regex/test2/',     expected => 'regex root: test2' },
+    { path => '/regex/test2_again',     expected => 'regex root: test2_again' },
+
+    { path => '/nested/capture/test3/baz',         expected => 'capture baz: test3' },
+
+    # This is a bug, as Dancer::Route::_init_prefix() doesn't detect this as a regex,
+    #  so the capture doesn't happen
+    #{ path => '/nested/regex/test3/quxx',         expected => 'regex quxx: test3' },
+);
+
+plan tests => 2*@tests;
+
+{
+    prefix '/capture/:word' => sub {
+      get '/foo'  => sub { 'capture foo: '  . params->{word} };
+      get '/'     => sub { 'capture root: ' . params->{word} };
+    };
+
+    #get '/bar'  => sub { 'regex bar: '  . join ',', splat };
+
+    prefix qr{/regex/([\w]+)} => sub {
+      get '/bar'  => sub { 'regex bar: '  . join ',', splat };
+      get '/'     => sub { 'regex root: ' . join ',', splat };
+    };
+
+    prefix '/nested' => sub {
+        prefix '/capture/:word' => sub {
+            get '/baz'  => sub { 'capture baz: '  . params->{word} };
+        };
+
+        prefix qr{/regex/([\w]+)} => sub {
+            get '/quxx'  => sub { 'regex quxx: '  . join ',', splat };
+        };
+    }
+}
+
+foreach my $test (@tests) {
+    my $path     = $test->{path};
+    my $expected = $test->{expected};
+
+    response_status_is         [GET => $path] => 200;
+    response_content_is_deeply [GET => $path] => $expected;
+}
+