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
72 if(my $arg = shift @_) {
73 if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
74 return bless {'__type_constraint'=>$arg}, $class;
77 $arg->isa('MooseX::Types::UndefinedType')
79 ## stub in case we'll need to handle these types differently
80 return bless {'__type_constraint'=>$arg}, $class;
81 } elsif(blessed $arg) {
82 __PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg);
84 __PACKAGE__->_throw_error("Argument cannot be '$arg'");
87 __PACKAGE__->_throw_error("This method [new] requires a single argument.");
91 =head2 __type_constraint ($type_constraint)
93 Set/Get the type_constraint.
97 sub __type_constraint {
100 if(defined(my $tc = shift @_)) {
101 $self->{__type_constraint} = $tc;
103 return $self->{__type_constraint};
105 __PACKAGE__->_throw_error('cannot call __type_constraint as a class method');
111 handle $self->isa since AUTOLOAD can't.
116 my ($self, $target) = @_;
117 if(defined $target) {
119 return $self->__type_constraint->isa($target);
131 handle $self->can since AUTOLOAD can't.
136 my ($self, $target) = @_;
137 if(defined $target) {
139 return $self->__type_constraint->can($target);
150 have meta examine the underlying type constraints
157 return $self->__type_constraint->meta;
163 properly delegate error messages
171 goto &Moose::throw_error;
176 We might need it later
186 Delegate to the decorator target.
192 my ($self, @args) = @_;
193 my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
195 ## We delegate with this method in an attempt to support a value of
196 ## __type_constraint which is also AUTOLOADing, in particular the class
197 ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
201 $return = $self->__type_constraint->$method(@args);
203 __PACKAGE__->_throw_error($@);
211 This program is free software; you can redistribute it and/or modify
212 it under the same terms as perl itself.