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};
19 # workaround for perl 5.8.5 bug
20 '==' => sub { 0+$_[0] == 0+$_[1] },
24 return $self->__type_constraint->name;
32 ## It's kind of ugly that we need to know about Union Types, but this
33 ## is needed for syntax compatibility. Maybe someday we'll all just do
36 my @args = @_[0,1]; ## arg 3 is special, see the overload docs.
37 my @tc = grep {blessed $_} map {
39 Moose::Util::TypeConstraints::find_or_parse_type_constraint($_)
40 || __PACKAGE__->_throw_error( "$_ is not a type constraint")
43 ( scalar @tc == scalar @args)
44 || __PACKAGE__->_throw_error(
45 "one of your type constraints is bad. Passed: ". join(', ', @args) ." Got: ". join(', ', @tc));
48 || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
50 my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
51 return Moose::Util::TypeConstraints::register_type_constraint($union);
59 This is a decorator object that contains an underlying type constraint. We use
60 this to control access to the type constraint and to add some features.
64 This class defines the following methods.
68 Old school instantiation
75 return $proto->_try_delegate('new', @_);
78 if(my $arg = shift @_) {
79 if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
80 return bless {'__type_constraint'=>$arg}, $class;
83 $arg->isa('MooseX::Types::UndefinedType')
85 ## stub in case we'll need to handle these types differently
86 return bless {'__type_constraint'=>$arg}, $class;
87 } elsif(blessed $arg) {
88 __PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg);
90 __PACKAGE__->_throw_error("Argument cannot be '$arg'");
93 __PACKAGE__->_throw_error("This method [new] requires a single argument.");
97 =head2 __type_constraint ($type_constraint)
99 Set/Get the type_constraint.
103 sub __type_constraint {
106 if(defined(my $tc = shift @_)) {
107 $self->{__type_constraint} = $tc;
109 return $self->{__type_constraint};
111 __PACKAGE__->_throw_error('cannot call __type_constraint as a class method');
117 handle $self->isa since AUTOLOAD can't - this tries both the type constraint,
118 and for a class type, the class.
126 ? $self->__type_constraint->isa(@_)
127 || $self->_try_delegate( 'isa', @_ )
128 : $self->SUPER::isa(@_);
133 handle $self->can since AUTOLOAD can't.
141 ? $self->_try_delegate( 'can', @_ )
142 : $self->SUPER::can(@_);
147 properly delegate error messages
155 goto &Moose::throw_error;
160 We might need it later
170 Delegate to the decorator target, unless this is a class type, in which
171 case it will try to delegate to the type object, then if that fails try
172 the class. The method 'new' is special cased to only be permitted on
173 the class; if there is no class, or it does not provide a new method,
174 an exception will be thrown.
179 my ($self, @args) = @_;
180 my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
182 ## We delegate with this method in an attempt to support a value of
183 ## __type_constraint which is also AUTOLOADing, in particular the class
184 ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
186 $self->_try_delegate($method, @args);
190 my ($self, $method, @args) = @_;
191 my $tc = $self->__type_constraint;
193 if ($tc->can('is_subtype_of')) { # Union can't
196 if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
197 $class = $search_tc->class;
200 $search_tc = $search_tc->parent;
201 last unless $search_tc && $search_tc->is_subtype_of('Object');
206 if ($method eq 'new') {
207 die "new called on type decorator for non-class-type ".$tc->name
209 die "new called on class type decorator ".$tc->name."\n"
210 ." for class ${class}\n"
211 ." which does not provide a new method - did you forget to load it?"
212 unless $class->can('new');
214 } elsif ($class && !$tc->can($method)) {
221 $inv->$method(@args);
226 This program is free software; you can redistribute it and/or modify
227 it under the same terms as perl itself.