X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FTypeDecorator.pm;h=67dd3ce0cdc5b020421e9f11a83cff74094c10bd;hb=8bf27efd5d9f5df49e2977fc04a6abd4ea8a5aca;hp=6f028138af5491db08ebeae1ab69c6a93898800b;hpb=d7d0bd99611df609fb566d2aa772e002ce0747c3;p=gitmo%2FMooseX-Types.git

diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm
index 6f02813..67dd3ce 100644
--- a/lib/MooseX/Types/TypeDecorator.pm
+++ b/lib/MooseX/Types/TypeDecorator.pm
@@ -16,17 +16,19 @@ 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) {
-        		return $self->__type_constraint->name;     		
+        		return $self->__type_constraint->name;
     		} else {
     			return "$self";
     		}
     },
     bool => sub { 1 },
     '|' => sub {
-        
+
         ## It's kind of ugly that we need to know about Union Types, but this
         ## is needed for syntax compatibility.  Maybe someday we'll all just do
         ## Or[Str,Str,Int]
@@ -49,7 +51,7 @@ use overload(
         return Moose::Util::TypeConstraints::register_type_constraint($union);
     },
     fallback => 1,
-    
+
 );
 
 =head1 DESCRIPTION
@@ -78,7 +80,7 @@ sub new {
             return bless {'__type_constraint'=>$arg}, $class;
         } elsif(
             blessed $arg &&
-            $arg->isa('MooseX::Types::UndefinedType') 
+            $arg->isa('MooseX::Types::UndefinedType')
           ) {
             ## stub in case we'll need to handle these types differently
             return bless {'__type_constraint'=>$arg}, $class;
@@ -88,7 +90,7 @@ sub new {
             __PACKAGE__->_throw_error("Argument cannot be '$arg'");
         }
     } else {
-        __PACKAGE__->_throw_error("This method [new] requires a single argument.");        
+        __PACKAGE__->_throw_error("This method [new] requires a single argument.");
     }
 }
 
@@ -99,26 +101,31 @@ Set/Get the type_constraint.
 =cut
 
 sub __type_constraint {
-    my $self = shift @_;    
+    my $self = shift @_;
     if(blessed $self) {
         if(defined(my $tc = shift @_)) {
             $self->{__type_constraint} = $tc;
         }
-        return $self->{__type_constraint};        
+        return $self->{__type_constraint};
     } else {
         __PACKAGE__->_throw_error('cannot call __type_constraint as a class method');
     }
 }
 
-=head2 isa
+=head2 C<isa>
 
-handle $self->isa since AUTOLOAD can't.
+handle C<< $self->isa >> since C<AUTOLOAD> can't - this tries both the type constraint,
+and for a class type, the class.
 
 =cut
 
 sub isa {
-  return 1 if $_[1]->isa('Moose::Meta::TypeConstraint');
-  shift->_try_delegate('isa', @_)
+  my $self = shift;
+  return
+    blessed $self
+      ? $self->__type_constraint->isa(@_)
+      || $self->_try_delegate( 'isa', @_ )
+      : $self->SUPER::isa(@_);
 }
 
 =head2 can
@@ -127,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
 
@@ -154,19 +167,23 @@ sub DESTROY {
 
 =head2 AUTOLOAD
 
-Delegate to the decorator target.
+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 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
 
 sub AUTOLOAD {
     my ($self, @args) = @_;
     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
-    
+
     ## We delegate with this method in an attempt to support a value of
     ## __type_constraint which is also AUTOLOADing, in particular the class
     ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
 
-    $self->_try_delegate($method, @args);    
+    $self->_try_delegate($method, @args);
 }
 
 sub _try_delegate {
@@ -181,19 +198,26 @@ 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
-            ? (
-                $method eq 'new' || $class->can($method)
-                    ? $class
-                    : $tc
-              )
-            : $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);
 }