1 package MooseX::Types::TypeDecorator;
3 #ABSTRACT: Wraps Moose::Meta::TypeConstraint objects with added features
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 This is a decorator object that contains an underlying type constraint. We use
58 this to control access to the type constraint and to add some features.
62 This class defines the following methods.
66 Old school instantiation
73 return $proto->_try_delegate('new', @_);
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 - this tries both the type constraint,
116 and for a class type, the class.
124 ? $self->__type_constraint->isa(@_)
125 || $self->_try_delegate( 'isa', @_ )
126 : $self->SUPER::isa(@_);
131 handle $self->can since AUTOLOAD can't.
139 ? $self->_try_delegate( 'can', @_ )
140 : $self->SUPER::can(@_);
145 properly delegate error messages
153 goto &Moose::throw_error;
158 We might need it later
168 Delegate to the decorator target, unless this is a class type, in which
169 case it will try to delegate to the type object, then if that fails try
170 the class. The method 'new' is special cased to only be permitted on
171 the class; if there is no class, or it does not provide a new method,
172 an exception will be thrown.
177 my ($self, @args) = @_;
178 my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
180 ## We delegate with this method in an attempt to support a value of
181 ## __type_constraint which is also AUTOLOADing, in particular the class
182 ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
184 $self->_try_delegate($method, @args);
188 my ($self, $method, @args) = @_;
189 my $tc = $self->__type_constraint;
191 if ($tc->can('is_subtype_of')) { # Union can't
194 if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
195 $class = $search_tc->class;
198 $search_tc = $search_tc->parent;
199 last unless $search_tc && $search_tc->is_subtype_of('Object');
204 if ($method eq 'new') {
205 die "new called on type decorator for non-class-type ".$tc->name
207 die "new called on class type decorator ".$tc->name."\n"
208 ." for class ${class}\n"
209 ." which does not provide a new method - did you forget to load it?"
210 unless $class->can('new');
212 } elsif ($class && !$tc->can($method)) {
219 $inv->$method(@args);
224 This program is free software; you can redistribute it and/or modify
225 it under the same terms as perl itself.