1 package MooseX::Types::TypeDecorator;
8 use Carp::Clan qw( ^MooseX::Types );
9 use Moose::Util::TypeConstraints ();
10 use Moose::Meta::TypeConstraint::Union;
11 use Scalar::Util qw(blessed);
16 my $tc = $self->{__type_constraint};
22 return $self->__type_constraint->name;
30 ## It's kind of ugly that we need to know about Union Types, but this
31 ## is needed for syntax compatibility. Maybe someday we'll all just do
34 my @args = @_[0,1]; ## arg 3 is special, see the overload docs.
35 my @tc = grep {blessed $_} map {
37 Moose::Util::TypeConstraints::find_or_parse_type_constraint($_)
38 || __PACKAGE__->_throw_error( "$_ is not a type constraint")
41 ( scalar @tc == scalar @args)
42 || __PACKAGE__->_throw_error(
43 "one of your type constraints is bad. Passed: ". join(', ', @args) ." Got: ". join(', ', @tc));
46 || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
48 my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
49 return Moose::Util::TypeConstraints::register_type_constraint($union);
57 MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
61 This is a decorator object that contains an underlying type constraint. We use
62 this to control access to the type constraint and to add some features.
66 This class defines the following methods.
70 Old school instantiation
76 if(my $arg = shift @_) {
77 if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
78 return bless {'__type_constraint'=>$arg}, $class;
81 $arg->isa('MooseX::Types::UndefinedType')
83 ## stub in case we'll need to handle these types differently
84 return bless {'__type_constraint'=>$arg}, $class;
85 } elsif(blessed $arg) {
86 __PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg);
88 __PACKAGE__->_throw_error("Argument cannot be '$arg'");
91 __PACKAGE__->_throw_error("This method [new] requires a single argument.");
95 =head2 __type_constraint ($type_constraint)
97 Set/Get the type_constraint.
101 sub __type_constraint {
104 if(defined(my $tc = shift @_)) {
105 $self->{__type_constraint} = $tc;
107 return $self->{__type_constraint};
109 __PACKAGE__->_throw_error('cannot call __type_constraint as a class method');
115 handle $self->isa since AUTOLOAD can't.
120 my ($self, $target) = @_;
121 if(defined $target) {
123 return $self->__type_constraint->isa($target);
135 handle $self->can since AUTOLOAD can't.
140 my ($self, $target) = @_;
141 if(defined $target) {
143 return $self->__type_constraint->can($target);
154 have meta examine the underlying type constraints
161 return $self->__type_constraint->meta;
167 properly delegate error messages
175 goto &Moose::throw_error;
180 We might need it later
190 Delegate to the decorator targe
196 my ($self, @args) = @_;
197 my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
199 ## We delegate with this method in an attempt to support a value of
200 ## __type_constraint which is also AUTOLOADing, in particular the class
201 ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
206 $return = $self->__type_constraint->$method(@args);
208 __PACKAGE__->_throw_error($@);
216 See L<MooseX::Types/AUTHOR>.
220 This program is free software; you can redistribute it and/or modify
221 it under the same terms as perl itself.