X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FTypeDecorator.pm;h=febb46a6469119e1cae7114725db5482d32640d8;hb=989b05700d2f7f091f29a395c9d8789d429ab74a;hp=12c7f4803b3bacd785f2913b07d38b3d41203974;hpb=442e42ba3e90b69452a0c8c2a78cd55d2304262a;p=gitmo%2FMooseX-Types.git diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm index 12c7f48..febb46a 100644 --- a/lib/MooseX/Types/TypeDecorator.pm +++ b/lib/MooseX/Types/TypeDecorator.pm @@ -1,15 +1,21 @@ package MooseX::Types::TypeDecorator; +#ABSTRACT: Wraps Moose::Meta::TypeConstraint objects with added features + use strict; use warnings; - use Carp::Clan qw( ^MooseX::Types ); use Moose::Util::TypeConstraints (); use Moose::Meta::TypeConstraint::Union; use Scalar::Util qw(blessed); use overload( + '0+' => sub { + my $self = shift @_; + my $tc = $self->{__type_constraint}; + return 0+$tc; + }, '""' => sub { my $self = shift @_; if(blessed $self) { @@ -18,16 +24,26 @@ use overload( 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] - my @tc = map { - blessed $_ ? $_ : - Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) - } @_; + my @args = @_[0,1]; ## arg 3 is special, see the overload docs. + my @tc = grep {blessed $_} map { + blessed $_ ? $_ : + Moose::Util::TypeConstraints::find_or_parse_type_constraint($_) + || __PACKAGE__->_throw_error( "$_ is not a type constraint") + } @args; + + ( scalar @tc == scalar @args) + || __PACKAGE__->_throw_error( + "one of your type constraints is bad. Passed: ". join(', ', @args) ." Got: ". join(', ', @tc)); + + ( scalar @tc >= 2 ) + || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union"); my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc); return Moose::Util::TypeConstraints::register_type_constraint($union); @@ -36,10 +52,6 @@ use overload( ); -=head1 NAME - -MooseX::Types::TypeDecorator - More flexible access to a Type Constraint - =head1 DESCRIPTION This is a decorator object that contains an underlying type constraint. We use @@ -56,7 +68,11 @@ Old school instantiation =cut sub new { - my $class = shift @_; + my $proto = shift; + if (ref($proto)) { + return $proto->_try_delegate('new', @_); + } + my $class = $proto; if(my $arg = shift @_) { if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) { return bless {'__type_constraint'=>$arg}, $class; @@ -67,12 +83,12 @@ sub new { ## stub in case we'll need to handle these types differently return bless {'__type_constraint'=>$arg}, $class; } elsif(blessed $arg) { - croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg; + __PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg); } else { - croak "Argument cannot be '$arg'"; + __PACKAGE__->_throw_error("Argument cannot be '$arg'"); } } else { - croak "This method [new] requires a single argument."; + __PACKAGE__->_throw_error("This method [new] requires a single argument."); } } @@ -90,27 +106,22 @@ sub __type_constraint { } return $self->{__type_constraint}; } else { - croak 'cannot call __type_constraint as a class method'; + __PACKAGE__->_throw_error('cannot call __type_constraint as a class method'); } } =head2 isa -handle $self->isa since AUTOLOAD can't. +handle $self->isa since AUTOLOAD can't - this tries both the type constraint, +and for a class type, the class. =cut sub isa { - my ($self, $target) = @_; - if(defined $target) { - if(blessed $self) { - return $self->__type_constraint->isa($target); - } else { - return; - } - } else { - return; - } + my $self = shift; + return + $self->__type_constraint->isa(@_) + || $self->_try_delegate('isa', @_); } =head2 can @@ -119,33 +130,21 @@ handle $self->can since AUTOLOAD can't. =cut -sub can { - my ($self, $target) = @_; - if(defined $target) { - if(blessed $self) { - return $self->__type_constraint->can($target); - } else { - return; - } - } else { - return; - } -} +sub can { shift->_try_delegate('can', @_) } -=head2 meta +=head2 _throw_error -have meta examine the underlying type constraints +properly delegate error messages =cut -sub meta { - my $self = shift @_; - if(blessed $self) { - return $self->__type_constraint->meta; - } +sub _throw_error { + shift; + require Moose; + unshift @_, 'Moose'; + goto &Moose::throw_error; } - =head2 DESTROY We might need it later @@ -158,33 +157,43 @@ sub DESTROY { =head2 AUTOLOAD -Delegate to the decorator targe +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. =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. - - my $return; - - eval { - $return = $self->__type_constraint->$method(@args); - }; if($@) { - croak $@; - } else { - return $return; - } + + $self->_try_delegate($method, @args); } -=head1 AUTHOR AND COPYRIGHT +sub _try_delegate { + my ($self, $method, @args) = @_; + my $tc = $self->__type_constraint; + my $class; + if ($tc->can('is_subtype_of')) { # Union can't + my $search_tc = $tc; + while (1) { + if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) { + $class = $search_tc->class; + last; + } + $search_tc = $search_tc->parent; + last unless $search_tc->is_subtype_of('Object'); + } + } + + my $inv = ($class && $class->can($method)) ? $class : $tc; -John Napiorkowski (jnapiorkowski) + $inv->$method(@args); +} =head1 LICENSE