Commit | Line | Data |
---|---|---|
4c2125a4 | 1 | package MooseX::Types::TypeDecorator; |
2 | ||
a706b0f2 | 3 | use strict; |
4 | use warnings; | |
4c2125a4 | 5 | |
bb5b7b28 | 6 | use Carp::Clan qw( ^MooseX::Types ); |
475bbd1d | 7 | use Moose::Util::TypeConstraints (); |
bb5b7b28 | 8 | use Moose::Meta::TypeConstraint::Union; |
9 | ||
4c2125a4 | 10 | use overload( |
11 | '""' => sub { | |
475bbd1d | 12 | shift->__type_constraint->name; |
4c2125a4 | 13 | }, |
cf1a8bfa | 14 | '|' => sub { |
bb5b7b28 | 15 | my @tc = grep {ref $_} @_; |
16 | my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc); | |
17 | return Moose::Util::TypeConstraints::register_type_constraint($union); | |
cf1a8bfa | 18 | }, |
4c2125a4 | 19 | ); |
20 | ||
21 | =head1 NAME | |
22 | ||
23 | MooseX::Types::TypeDecorator - More flexible access to a Type Constraint | |
24 | ||
25 | =head1 DESCRIPTION | |
26 | ||
27 | This is a decorator object that contains an underlying type constraint. We use | |
28 | this to control access to the type constraint and to add some features. | |
29 | ||
a706b0f2 | 30 | =head1 METHODS |
4c2125a4 | 31 | |
a706b0f2 | 32 | This class defines the following methods. |
4c2125a4 | 33 | |
a706b0f2 | 34 | =head2 new |
4c2125a4 | 35 | |
a706b0f2 | 36 | Old school instantiation |
4c2125a4 | 37 | |
38 | =cut | |
39 | ||
a706b0f2 | 40 | sub new { |
475bbd1d | 41 | my $class = shift @_; |
42 | if(my $arg = shift @_) { | |
43 | if(ref $arg && $arg->isa('Moose::Meta::TypeConstraint')) { | |
44 | return bless {'__type_constraint'=>$arg}, $class; | |
45 | } elsif(ref $arg && $arg->isa('MooseX::Types::UndefinedType')) { | |
46 | ## stub in case we'll need to handle these types differently | |
47 | return bless {'__type_constraint'=>$arg}, $class; | |
48 | } else { | |
49 | croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType')"; | |
50 | } | |
bb5b7b28 | 51 | } else { |
475bbd1d | 52 | croak "This method [new] requires a single argument"; |
bb5b7b28 | 53 | } |
a706b0f2 | 54 | } |
4c2125a4 | 55 | |
a706b0f2 | 56 | =head type_constraint ($type_constraint) |
4c2125a4 | 57 | |
e088dd03 | 58 | Set/Get the type_constraint. |
4c2125a4 | 59 | |
60 | =cut | |
61 | ||
475bbd1d | 62 | sub __type_constraint { |
a706b0f2 | 63 | my $self = shift @_; |
e088dd03 | 64 | if(defined(my $tc = shift @_)) { |
475bbd1d | 65 | $self->{__type_constraint} = $tc; |
a706b0f2 | 66 | } |
475bbd1d | 67 | return $self->{__type_constraint}; |
a706b0f2 | 68 | } |
4c2125a4 | 69 | |
bb5b7b28 | 70 | =head2 isa |
71 | ||
72 | handle $self->isa since AUTOLOAD can't. | |
73 | ||
74 | =cut | |
75 | ||
76 | sub isa { | |
77 | my ($self, $target) = @_; | |
78 | if(defined $target) { | |
475bbd1d | 79 | return $self->__type_constraint->isa($target); |
bb5b7b28 | 80 | } else { |
81 | return; | |
82 | } | |
83 | } | |
84 | ||
85 | =head2 can | |
86 | ||
87 | handle $self->can since AUTOLOAD can't. | |
88 | ||
89 | =cut | |
90 | ||
91 | sub can { | |
92 | my ($self, $target) = @_; | |
93 | if(defined $target) { | |
475bbd1d | 94 | return $self->__type_constraint->can($target); |
bb5b7b28 | 95 | } else { |
96 | return; | |
97 | } | |
98 | } | |
99 | ||
a706b0f2 | 100 | =head2 DESTROY |
4c2125a4 | 101 | |
a706b0f2 | 102 | We might need it later |
4c2125a4 | 103 | |
a706b0f2 | 104 | =cut |
4c2125a4 | 105 | |
a706b0f2 | 106 | sub DESTROY { |
107 | return; | |
108 | } | |
4c2125a4 | 109 | |
a706b0f2 | 110 | =head2 AUTOLOAD |
4c2125a4 | 111 | |
a706b0f2 | 112 | Delegate to the decorator targe |
4c2125a4 | 113 | |
a706b0f2 | 114 | =cut |
4c2125a4 | 115 | |
e088dd03 | 116 | sub AUTOLOAD { |
475bbd1d | 117 | my ($self, @args) = @_; |
a706b0f2 | 118 | my ($method) = (our $AUTOLOAD =~ /([^:]+)$/); |
475bbd1d | 119 | if($self->__type_constraint->can($method)) { |
120 | return $self->__type_constraint->$method(@args); | |
121 | } else { | |
122 | croak "Method '$method' is not supported"; | |
123 | } | |
a706b0f2 | 124 | } |
4c2125a4 | 125 | |
126 | =head1 AUTHOR AND COPYRIGHT | |
127 | ||
128 | John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org> | |
129 | ||
130 | =head1 LICENSE | |
131 | ||
132 | This program is free software; you can redistribute it and/or modify | |
133 | it under the same terms as perl itself. | |
134 | ||
135 | =cut | |
136 | ||
137 | 1; |