X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FTypeDecorator.pm;h=16e4fe0ba71db72e721c127e86907daddf8a8317;hb=7f95d0bf38da072ac2fba35dcfe29abfa62037a3;hp=febb46a6469119e1cae7114725db5482d32640d8;hpb=989b05700d2f7f091f29a395c9d8789d429ab74a;p=gitmo%2FMooseX-Types.git

diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm
index febb46a..16e4fe0 100644
--- a/lib/MooseX/Types/TypeDecorator.pm
+++ b/lib/MooseX/Types/TypeDecorator.pm
@@ -158,8 +158,10 @@ sub DESTROY {
 =head2 AUTOLOAD
 
 Delegate to the decorator target, unless this is a class type, in which
-case it will call the class' version of the method if present, and fall
-back to the type's version if not.
+case it will try to delegate to the type object, then if that fails try
+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
 
@@ -190,7 +192,21 @@ sub _try_delegate {
         }
     }
         
-    my $inv = ($class && $class->can($method)) ? $class : $tc;
+    my $inv = do {
+        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
+        }
+    };
 
     $inv->$method(@args);
 }