X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FTypeDecorator.pm;h=519cad75e1e5cc2de5a2f834191b90c61f23c13e;hb=e7d06577ac86f8d5aa7f917e0dbcb42fe4a62b3e;hp=79c77ee12117394ab19936635877978c4c3d9fef;hpb=d8f30dd42921bb59d34e1a44559c673654cdc0d1;p=gitmo%2FMooseX-Types.git diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm index 79c77ee..519cad7 100644 --- a/lib/MooseX/Types/TypeDecorator.pm +++ b/lib/MooseX/Types/TypeDecorator.pm @@ -6,6 +6,7 @@ use warnings; use Carp::Clan qw( ^MooseX::Types ); use Moose::Util::TypeConstraints (); use Moose::Meta::TypeConstraint::Union; +use Scalar::Util qw(blessed); use overload( '""' => sub { @@ -17,12 +18,15 @@ use overload( ## is needed for syntax compatibility. Maybe someday we'll all just do ## Or[Str,Str,Int] - my @tc = grep {ref $_} @_; + my @tc = grep {blessed $_} @_; my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc); return Moose::Util::TypeConstraints::register_type_constraint($union); }, + fallback => 1, + ); + =head1 NAME MooseX::Types::TypeDecorator - More flexible access to a Type Constraint @@ -45,18 +49,21 @@ Old school instantiation sub new { my $class = shift @_; if(my $arg = shift @_) { - if(ref $arg && $arg->isa('Moose::Meta::TypeConstraint')) { + if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) { return bless {'__type_constraint'=>$arg}, $class; - } elsif(ref $arg && $arg->isa('MooseX::Types::UndefinedType')) { + } elsif( + blessed $arg && + $arg->isa('MooseX::Types::UndefinedType') + ) { ## stub in case we'll need to handle these types differently return bless {'__type_constraint'=>$arg}, $class; - } elsif(ref $arg) { - croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". ref $arg; + } elsif(blessed $arg) { + croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg; } else { croak "Argument cannot be '$arg'"; } } else { - croak "This method [new] requires a single argument of 'arg'."; + croak "This method [new] requires a single argument."; } } @@ -68,10 +75,15 @@ Set/Get the type_constraint. sub __type_constraint { my $self = shift @_; - if(defined(my $tc = shift @_)) { - $self->{__type_constraint} = $tc; + + if(blessed $self) { + if(defined(my $tc = shift @_)) { + $self->{__type_constraint} = $tc; + } + return $self->{__type_constraint}; + } else { + croak 'cannot call __type_constraint as a class method'; } - return $self->{__type_constraint}; } =head2 isa @@ -81,7 +93,7 @@ handle $self->isa since AUTOLOAD can't. =cut sub isa { - my ($self, $target) = @_; + my ($self, $target) = @_; if(defined $target) { return $self->__type_constraint->isa($target); } else { @@ -126,7 +138,7 @@ sub AUTOLOAD { if($self->__type_constraint->can($method)) { return $self->__type_constraint->$method(@args); } else { - croak "Method '$method' is not supported"; + croak "Method '$method' is not supported for ". ref($self->__type_constraint); } }