From: Matt S Trout <mst@shadowcat.co.uk>
Date: Tue, 14 Aug 2012 17:43:13 +0000 (+0000)
Subject: Fix model/view/controller methods to handle stringifiable objects
X-Git-Tag: 5.90016~5
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=4995a5cebbc06c813c20daabc8d248247f33cb37

Fix model/view/controller methods to handle stringifiable objects

Previously, we tested ref() and assumed if that was true that we'd been
supplied with a regexp; by switching to using Safe::Isa to check for

  $thing->$_isa('Regexp')

a stringifiable object will still get handled correctly. This is necessary
when using string overloading tools such as i18n.pm or HTML::String.
---

diff --git a/Changes b/Changes
index baf322f..06eadd6 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 # This file documents the revision history for Perl extension Catalyst.
 
+  - Fix model/view/controller methods to handle stringifiable objects
   - Fix RT#78377 - IIS7 ignores response body for 3xx requests, which
     causes (a different) response to be broken when using keepalive.
     Fixed by applying Middleware which removes the response body and
diff --git a/Makefile.PL b/Makefile.PL
index c8ff69a..af8361f 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -59,6 +59,7 @@ requires 'Time::HiRes';
 requires 'Tree::Simple' => '1.15';
 requires 'Tree::Simple::Visitor::FindByPath';
 requires 'Try::Tiny';
+requires 'Safe::Isa';
 requires 'URI' => '1.35';
 requires 'Task::Weaken';
 requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness
diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm
index e2d3ca9..2f9225f 100644
--- a/lib/Catalyst.pm
+++ b/lib/Catalyst.pm
@@ -33,6 +33,7 @@ use Catalyst::EngineLoader;
 use utf8;
 use Carp qw/croak carp shortmess/;
 use Try::Tiny;
+use Safe::Isa;
 use Plack::Middleware::Conditional;
 use Plack::Middleware::ReverseProxy;
 use Plack::Middleware::IIS6ScriptNameFix;
@@ -547,13 +548,13 @@ sub _comp_names_search_prefixes {
     # undef for a name will return all
     return keys %eligible if !defined $name;
 
-    my $query  = ref $name ? $name : qr/^$name$/i;
+    my $query  = $name->$_isa('Regexp') ? $name : qr/^$name$/i;
     my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible;
 
     return @result if @result;
 
     # if we were given a regexp to search against, we're done.
-    return if ref $name;
+    return if $name->$_isa('Regexp');
 
     # skip regexp fallback if configured
     return
@@ -644,7 +645,7 @@ sub controller {
 
     my $appclass = ref($c) || $c;
     if( $name ) {
-        unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
+        unless ( $name->$_isa('Regexp') ) { # Direct component hash lookup to avoid costly regexps
             my $comps = $c->components;
             my $check = $appclass."::Controller::".$name;
             return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
@@ -682,7 +683,7 @@ sub model {
     my ( $c, $name, @args ) = @_;
     my $appclass = ref($c) || $c;
     if( $name ) {
-        unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
+        unless ( $name->$_isa('Regexp') ) { # Direct component hash lookup to avoid costly regexps
             my $comps = $c->components;
             my $check = $appclass."::Model::".$name;
             return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
@@ -741,7 +742,7 @@ sub view {
 
     my $appclass = ref($c) || $c;
     if( $name ) {
-        unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
+        unless ( $name->$_isa('Regexp') ) { # Direct component hash lookup to avoid costly regexps
             my $comps = $c->components;
             my $check = $appclass."::View::".$name;
             if( exists $comps->{$check} ) {
diff --git a/t/aggregate/unit_core_mvc.t b/t/aggregate/unit_core_mvc.t
index b04c3a3..c84e1d4 100644
--- a/t/aggregate/unit_core_mvc.t
+++ b/t/aggregate/unit_core_mvc.t
@@ -1,4 +1,4 @@
-use Test::More tests => 51;
+use Test::More;
 use strict;
 use warnings;
 
@@ -24,6 +24,12 @@ my @complist =
     __PACKAGE__->setup_log;
 }
 
+{
+    package MyStringThing;
+
+    use overload '""' => sub { $_[0]->{string} }, fallback => 1;
+}
+
 is( MyMVCTestApp->view('View'), 'MyMVCTestApp::V::View', 'V::View ok' );
 
 is( MyMVCTestApp->controller('Controller'),
@@ -117,6 +123,18 @@ is ( MyMVCTestApp->model , 'MyMVCTestApp::Model::M', 'default_model in class met
     # object w/ qr{}
     is_deeply( [ MyMVCTestApp->model( qr{Test} ) ], [ MyMVCTestApp->components->{'MyMVCTestApp::Model::Test::Object'} ], 'Object returned' );
 
+    is_deeply([ MyMVCTestApp->model( bless({ string => 'Model' }, 'MyStringThing') ) ], [ MyMVCTestApp->components->{'MyMVCTestApp::M::Model'} ], 'Explicit model search with overloaded object');
+
+    {
+        my $warnings = 0;
+        no warnings 'redefine';
+        local *Catalyst::Log::warn = sub { $warnings++ };
+
+        # object w/ regexp fallback
+        is_deeply( [ MyMVCTestApp->model( bless({ string => 'Test' }, 'MyStringThing') ) ], [ MyMVCTestApp->components->{'MyMVCTestApp::Model::Test::Object'} ], 'Object returned' );
+        ok( $warnings, 'regexp fallback warnings' );
+    }
+
     {
         my $warnings = 0;
         no warnings 'redefine';
@@ -225,3 +243,5 @@ is ( MyMVCTestApp->model , 'MyMVCTestApp::Model::M', 'default_model in class met
     is( MyApp::WithoutRegexFallback->controller('Foo'), undef, 'no controller Foo found');
     ok( !$warnings, 'no regexp fallback warnings' );
 }
+
+done_testing;