From: Matt S Trout <mst@shadowcat.co.uk>
Date: Fri, 18 May 2012 21:18:07 +0000 (+0000)
Subject: Special case new to avoid unexpected exceptions on unloaded classes
X-Git-Tag: v0.34~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Types.git;a=commitdiff_plain;h=7f95d0bf38da072ac2fba35dcfe29abfa62037a3

Special case new to avoid unexpected exceptions on unloaded classes
---

diff --git a/Changes b/Changes
index 20817e0..0005a0c 100644
--- a/Changes
+++ b/Changes
@@ -2,6 +2,8 @@ Revision history for MooseX-Types
 
 {{$NEXT}}
 
+        - Special case new to avoid unexpected exceptions on unloaded classes
+
 0.33    2012-05-18
 
         - Switch delegation order to prioritise type over class except for new
diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm
index 056eff7..16e4fe0 100644
--- a/lib/MooseX/Types/TypeDecorator.pm
+++ b/lib/MooseX/Types/TypeDecorator.pm
@@ -159,8 +159,9 @@ sub DESTROY {
 
 Delegate to the decorator target, unless this is a class type, in which
 case it will try to delegate to the type object, then if that fails try
-the class. The method 'new' is special cased to go to the class first
-if present.
+the class. The method 'new' is special cased to only be permitted on
+the class; if there is no class, or it does not provide a new method,
+an exception will be thrown.
 
 =cut
 
@@ -192,9 +193,15 @@ sub _try_delegate {
     }
         
     my $inv = do {
-      if ($tc->can($method) and $method ne 'new') {
-            $tc
-        } elsif ($class && $class->can($method)) {
+        if ($method eq 'new') {
+            die "new called on type decorator for non-class-type ".$tc->name
+                unless $class;
+            die "new called on class type decorator ".$tc->name."\n"
+                ." for class ${class}\n"
+                ." which does not provide a new method - did you forget to load it?"
+                unless $class->can('new');
+            $class
+        } elsif ($class && !$tc->can($method)) {
             $class
         } else {
             $tc
diff --git a/t/22_class_type.t b/t/22_class_type.t
index fe90fac..8df1e4c 100644
--- a/t/22_class_type.t
+++ b/t/22_class_type.t
@@ -5,13 +5,24 @@ use Test::More;
 BEGIN {
   package MyTypes;
 
-  use MooseX::Types -declare => [ 'ClassyType' ];
+  use MooseX::Types -declare => [ 'ClassyType', 'NoClass' ];
 
   class_type 'ClassyClass';
 
   subtype ClassyType, as 'ClassyClass';
 
-  #class_type ClassyType, { class => 'ClassyClass' };
+  subtype NoClass, as 'Item', where { 1 };
+}
+
+BEGIN {
+
+  ok(!eval { MyTypes::ClassyType->new }, 'new without class loaded explodes');
+
+  like($@, qr/does not provide/, 'right exception');
+
+  ok(!eval { MyTypes::NoClass->new }, 'new on non-class type');
+
+  like($@, qr/non-class-type/, 'right exception');
 }
 
 BEGIN {