X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FTypeDecorator.pm;h=808e7d6596e54ae1520efd6c2a68e1c9d4d84c18;hb=f5559e1ce7a42af91a0e64915a8cb1e08958ae63;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..808e7d6 100644 --- a/lib/MooseX/Types/TypeDecorator.pm +++ b/lib/MooseX/Types/TypeDecorator.pm @@ -1,14 +1,55 @@ package MooseX::Types::TypeDecorator; +our $VERSION = "0.25"; -use Moose; +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"; + } }, - '&' => sub {warn 'got code context'}, + 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); + }, + fallback => 1, + ); =head1 NAME @@ -20,55 +61,159 @@ MooseX::Types::TypeDecorator - More flexible access to a Type Constraint 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 -The following types are defined in this class. +This class defines the following methods. -=head2 Moose::Meta::TypeConstraint +=head2 new -Used to make sure we can properly validate incoming type constraints. +Old school instantiation =cut -Moose::Util::TypeConstraints::class_type 'Moose::Meta::TypeConstraint'; +sub new { + my $class = shift @_; + 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 -=head2 MooseX::Types::UndefinedType +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'); + } +} -Used since sometimes our constraint is an unknown type. +=head2 isa + +handle $self->isa since AUTOLOAD can't. =cut -Moose::Util::TypeConstraints::class_type 'MooseX::Types::UndefinedType'; +sub isa { + my ($self, $target) = @_; + if(defined $target) { + if(blessed $self) { + return $self->__type_constraint->isa($target); + } else { + return; + } + } else { + return; + } +} + + +=head2 can -=head1 ATTRIBUTES +handle $self->can since AUTOLOAD can't. -This class defines the following attributes +=cut + +sub can { + my ($self, $target) = @_; + if(defined $target) { + if(blessed $self) { + return $self->__type_constraint->can($target); + } else { + return; + } + } else { + return; + } +} -=head2 type_constraint +=head2 meta -This is the type constraint that we are delegating +have meta examine the underlying type constraints =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 meta { + my $self = shift @_; + if(blessed $self) { + return $self->__type_constraint->meta; + } +} -=head1 METHODS +=head2 _throw_error -This class defines the following methods. +properly delegate error messages + +=cut + +sub _throw_error { + shift; + require Moose; + unshift @_, 'Moose'; + goto &Moose::throw_error; +} + +=head2 DESTROY + +We might need it later -=head1 AUTHOR AND COPYRIGHT +=cut + +sub DESTROY { + return; +} + +=head2 AUTOLOAD + +Delegate to the decorator targe + +=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. + + my $return; + + eval { + $return = $self->__type_constraint->$method(@args); + }; if($@) { + __PACKAGE__->_throw_error($@); + } else { + return $return; + } +} + +=head1 AUTHOR + +See L. =head1 LICENSE