add workaround for perl 5.8.5 bug

[gitmo/MooseX-Types.git] / lib / MooseX / Types / TypeDecorator.pm

diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm
index febb46a..2d1098d 100644 (file)
--- a/lib/MooseX/Types/TypeDecorator.pm
+++ b/lib/MooseX/Types/TypeDecorator.pm
@@ -16,6 +16,8 @@ use overload(
             my $tc = $self->{__type_constraint};
             return 0+$tc;
      },
+    # workaround for perl 5.8.5 bug
+    '==' => sub { 0+$_[0] == 0+$_[1] },
     '""' => sub {
                my $self = shift @_;
                if(blessed $self) {
@@ -120,8 +122,10 @@ and for a class type, the class.
 sub isa {
   my $self = shift;
   return
-    $self->__type_constraint->isa(@_)
-    || $self->_try_delegate('isa', @_);
+    blessed $self
+      ? $self->__type_constraint->isa(@_)
+      || $self->_try_delegate( 'isa', @_ )
+      : $self->SUPER::isa(@_);
 }
 
 =head2 can
@@ -130,7 +134,13 @@ handle $self->can since AUTOLOAD can't.
 
 =cut
 
-sub can { shift->_try_delegate('can', @_) }
+sub can {
+    my $self = shift;
+
+    return blessed $self
+        ? $self->_try_delegate( 'can', @_ )
+        : $self->SUPER::can(@_);
+}
 
 =head2 _throw_error
 
@@ -158,8 +168,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
 
@@ -186,11 +198,25 @@ sub _try_delegate {
                 last;
             }
             $search_tc = $search_tc->parent;
-            last unless $search_tc->is_subtype_of('Object');
+            last unless $search_tc && $search_tc->is_subtype_of('Object');
         }
     }
         
-    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);
 }