update to released version
[gitmo/MooseX-Types.git] / lib / MooseX / Types / TypeDecorator.pm
CommitLineData
4c2125a4 1package MooseX::Types::TypeDecorator;
2
a706b0f2 3use strict;
4use warnings;
4c2125a4 5
c1260541 6
bb5b7b28 7use Carp::Clan qw( ^MooseX::Types );
475bbd1d 8use Moose::Util::TypeConstraints ();
bb5b7b28 9use Moose::Meta::TypeConstraint::Union;
371efa05 10use Scalar::Util qw(blessed);
bb5b7b28 11
4c2125a4 12use overload(
13 '""' => sub {
c1260541 14 my $self = shift @_;
15 if(blessed $self) {
16 return $self->__type_constraint->name;
17 } else {
18 return "$self";
19 }
4c2125a4 20 },
cf1a8bfa 21 '|' => sub {
686e5888 22
23 ## It's kind of ugly that we need to know about Union Types, but this
24 ## is needed for syntax compatibility. Maybe someday we'll all just do
25 ## Or[Str,Str,Int]
26
371efa05 27 my @tc = grep {blessed $_} @_;
bb5b7b28 28 my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
29 return Moose::Util::TypeConstraints::register_type_constraint($union);
cf1a8bfa 30 },
1d9a68a6 31 fallback => 1,
32
4c2125a4 33);
34
35=head1 NAME
36
37MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
38
39=head1 DESCRIPTION
40
41This is a decorator object that contains an underlying type constraint. We use
42this to control access to the type constraint and to add some features.
43
a706b0f2 44=head1 METHODS
4c2125a4 45
a706b0f2 46This class defines the following methods.
4c2125a4 47
a706b0f2 48=head2 new
4c2125a4 49
a706b0f2 50Old school instantiation
4c2125a4 51
52=cut
53
a706b0f2 54sub new {
475bbd1d 55 my $class = shift @_;
56 if(my $arg = shift @_) {
371efa05 57 if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
475bbd1d 58 return bless {'__type_constraint'=>$arg}, $class;
e7d06577 59 } elsif(
60 blessed $arg &&
61 $arg->isa('MooseX::Types::UndefinedType')
62 ) {
475bbd1d 63 ## stub in case we'll need to handle these types differently
64 return bless {'__type_constraint'=>$arg}, $class;
371efa05 65 } elsif(blessed $arg) {
66 croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
475bbd1d 67 } else {
d8f30dd4 68 croak "Argument cannot be '$arg'";
475bbd1d 69 }
bb5b7b28 70 } else {
e7d06577 71 croak "This method [new] requires a single argument.";
bb5b7b28 72 }
a706b0f2 73}
4c2125a4 74
5a9b6d38 75=head2 __type_constraint ($type_constraint)
4c2125a4 76
e088dd03 77Set/Get the type_constraint.
4c2125a4 78
79=cut
80
475bbd1d 81sub __type_constraint {
c1260541 82 my $self = shift @_;
371efa05 83 if(blessed $self) {
84 if(defined(my $tc = shift @_)) {
85 $self->{__type_constraint} = $tc;
86 }
87 return $self->{__type_constraint};
88 } else {
89 croak 'cannot call __type_constraint as a class method';
a706b0f2 90 }
a706b0f2 91}
4c2125a4 92
bb5b7b28 93=head2 isa
94
95handle $self->isa since AUTOLOAD can't.
96
97=cut
98
99sub isa {
371efa05 100 my ($self, $target) = @_;
bb5b7b28 101 if(defined $target) {
c1260541 102 if(blessed $self) {
103 return $self->__type_constraint->isa($target);
104 } else {
105 return;
106 }
bb5b7b28 107 } else {
108 return;
109 }
110}
111
112=head2 can
113
114handle $self->can since AUTOLOAD can't.
115
116=cut
117
118sub can {
119 my ($self, $target) = @_;
120 if(defined $target) {
c1260541 121 if(blessed $self) {
122 return $self->__type_constraint->can($target);
123 } else {
124 return;
125 }
bb5b7b28 126 } else {
127 return;
128 }
129}
130
c1260541 131=head2 meta
132
133have meta examine the underlying type constraints
134
135=cut
136
137sub meta {
138 my $self = shift @_;
139 if(blessed $self) {
140 return $self->__type_constraint->meta;
141 }
142}
143
144
a706b0f2 145=head2 DESTROY
4c2125a4 146
a706b0f2 147We might need it later
4c2125a4 148
a706b0f2 149=cut
4c2125a4 150
a706b0f2 151sub DESTROY {
152 return;
153}
4c2125a4 154
a706b0f2 155=head2 AUTOLOAD
4c2125a4 156
a706b0f2 157Delegate to the decorator targe
4c2125a4 158
a706b0f2 159=cut
4c2125a4 160
e088dd03 161sub AUTOLOAD {
077ac262 162
475bbd1d 163 my ($self, @args) = @_;
a706b0f2 164 my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
077ac262 165
166 ## We delegate with this method in an attempt to support a value of
167 ## __type_constraint which is also AUTOLOADing, in particular the class
168 ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
169
170 my $return;
171
172 eval {
173 $return = $self->__type_constraint->$method(@args);
174 }; if($@) {
175 croak $@;
475bbd1d 176 } else {
077ac262 177 return $return;
475bbd1d 178 }
a706b0f2 179}
4c2125a4 180
181=head1 AUTHOR AND COPYRIGHT
182
183John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
184
185=head1 LICENSE
186
187This program is free software; you can redistribute it and/or modify
188it under the same terms as perl itself.
189
190=cut
191
1921;