lib/MooseX/Types/TypeDecorator.pm

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