X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FTypeDecorator.pm;h=7bbfa3287e100c5f4b8e9d76f93444546f60de89;hb=e513c4a5c345b572ecc63b4af1c858cacfd79de4;hp=1d9d7766fa2fb498c12d10b33562a48733fb358e;hpb=20b6a7d178dbaa6cd1ba946e53c1a4af3a4006eb;p=gitmo%2FMooseX-Types.git diff --git a/lib/MooseX/Types/TypeDecorator.pm b/lib/MooseX/Types/TypeDecorator.pm index 1d9d776..7bbfa32 100644 --- a/lib/MooseX/Types/TypeDecorator.pm +++ b/lib/MooseX/Types/TypeDecorator.pm @@ -1,74 +1,215 @@ package MooseX::Types::TypeDecorator; -use Moose; +#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 (); +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 { - shift->type_constraint->name; + my $self = shift @_; + if(blessed $self) { + 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] + + 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); }, - '&' => sub {warn 'got code context'}, + fallback => 1, + ); -=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 this to control access to the type constraint and to add some features. -=head1 TYPES +=head1 METHODS + +This class defines the following methods. + +=head2 new + +Old school instantiation + +=cut + +sub new { + 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; + } 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(blessed $arg) { + __PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg); + } else { + __PACKAGE__->_throw_error("Argument cannot be '$arg'"); + } + } else { + __PACKAGE__->_throw_error("This method [new] requires a single argument."); + } +} + +=head2 __type_constraint ($type_constraint) + +Set/Get the type_constraint. + +=cut -The following types are defined in this class. +sub __type_constraint { + my $self = shift @_; + if(blessed $self) { + if(defined(my $tc = shift @_)) { + $self->{__type_constraint} = $tc; + } + return $self->{__type_constraint}; + } else { + __PACKAGE__->_throw_error('cannot call __type_constraint as a class method'); + } +} -=head2 Moose::Meta::TypeConstraint +=head2 isa -Used to make sure we can properly validate incoming type constraints. +handle $self->isa since AUTOLOAD can't - this tries both the type constraint, +and for a class type, the class. =cut -Moose::Util::TypeConstraints::class_type 'Moose::Meta::TypeConstraint'; +sub isa { + my $self = shift; + return + $self->__type_constraint->isa(@_) + || $self->_try_delegate('isa', @_); +} -=head2 MooseX::Types::UndefinedType +=head2 can -Used since sometimes our constraint is an unknown type. +handle $self->can since AUTOLOAD can't. =cut -Moose::Util::TypeConstraints::class_type 'MooseX::Types::UndefinedType'; +sub can { shift->_try_delegate('can', @_) } + +=head2 _throw_error -=head1 ATTRIBUTES +properly delegate error messages -This class defines the following attributes +=cut -=head2 type_constraint +sub _throw_error { + shift; + require Moose; + unshift @_, 'Moose'; + goto &Moose::throw_error; +} -This is the type constraint that we are delegating +=head2 DESTROY + +We might need it later =cut -has 'type_constraint' => ( - is=>'ro', - isa=>'Moose::Meta::TypeConstraint|MooseX::Types::UndefinedType', - handles=>[ - grep { - $_ ne 'meta' && $_ ne '(""'; - } map { - $_->{name}; - } Moose::Meta::TypeConstraint->meta->compute_all_applicable_methods, - ], -); +sub DESTROY { + return; +} -=head1 METHODS +=head2 AUTOLOAD -This class defines the following methods. +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. -=head1 AUTHOR AND COPYRIGHT +=cut -John Napiorkowski (jnapiorkowski) +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); +} + +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 && $search_tc->is_subtype_of('Object'); + } + } + + 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); +} =head1 LICENSE