1 package MooseX::Types::TypeDecorator;
6 use Carp::Clan qw( ^MooseX::Types );
7 use Moose::Util::TypeConstraints ();
8 use Moose::Meta::TypeConstraint::Union;
9 use Scalar::Util qw(blessed);
13 return shift->__type_constraint->name;
17 ## It's kind of ugly that we need to know about Union Types, but this
18 ## is needed for syntax compatibility. Maybe someday we'll all just do
21 my @tc = grep {blessed $_} @_;
22 my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
23 return Moose::Util::TypeConstraints::register_type_constraint($union);
30 MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
34 This is a decorator object that contains an underlying type constraint. We use
35 this to control access to the type constraint and to add some features.
39 This class defines the following methods.
43 Old school instantiation
49 if(my $arg = shift @_) {
50 if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
51 return bless {'__type_constraint'=>$arg}, $class;
52 } elsif(blessed $arg && $arg->isa('MooseX::Types::UndefinedType')) {
53 ## stub in case we'll need to handle these types differently
54 return bless {'__type_constraint'=>$arg}, $class;
55 } elsif(blessed $arg) {
56 croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
58 croak "Argument cannot be '$arg'";
61 croak "This method [new] requires a single argument of 'arg'.";
65 =head __type_constraint ($type_constraint)
67 Set/Get the type_constraint.
71 sub __type_constraint {
75 if(defined(my $tc = shift @_)) {
76 $self->{__type_constraint} = $tc;
78 return $self->{__type_constraint};
80 croak 'cannot call __type_constraint as a class method';
86 handle $self->isa since AUTOLOAD can't.
91 my ($self, $target) = @_;
93 return $self->__type_constraint->isa($target);
101 handle $self->can since AUTOLOAD can't.
106 my ($self, $target) = @_;
107 if(defined $target) {
108 return $self->__type_constraint->can($target);
116 We might need it later
126 Delegate to the decorator targe
131 my ($self, @args) = @_;
132 my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
133 if($self->__type_constraint->can($method)) {
134 return $self->__type_constraint->$method(@args);
136 croak "Method '$method' is not supported";
140 =head1 AUTHOR AND COPYRIGHT
142 John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
146 This program is free software; you can redistribute it and/or modify
147 it under the same terms as perl itself.