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 @tc = grep {blessed $_} @_;
  28         my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
  29         return Moose::Util::TypeConstraints::register_type_constraint($union);
  30     },
  31     fallback => 1,
  32
  33 );
  34
  35 =head1 NAME
  36
  37 MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
  38
  39 =head1 DESCRIPTION
  40
  41 This is a decorator object that contains an underlying type constraint.  We use
  42 this to control access to the type constraint and to add some features.
  43
  44 =head1 METHODS
  45
  46 This class defines the following methods.
  47
  48 =head2 new
  49
  50 Old school instantiation
  51
  52 =cut
  53
  54 sub new {
  55     my $class = shift @_;
  56     if(my $arg = shift @_) {
  57         if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
  58             return bless {'__type_constraint'=>$arg}, $class;
  59         } elsif(
  60             blessed $arg &&
  61             $arg->isa('MooseX::Types::UndefinedType')
  62           ) {
  63             ## stub in case we'll need to handle these types differently
  64             return bless {'__type_constraint'=>$arg}, $class;
  65         } elsif(blessed $arg) {
  66             croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
  67         } else {
  68             croak "Argument cannot be '$arg'";
  69         }
  70     } else {
  71         croak "This method [new] requires a single argument.";
  72     }
  73 }
  74
  75 =head2 __type_constraint ($type_constraint)
  76
  77 Set/Get the type_constraint.
  78
  79 =cut
  80
  81 sub __type_constraint {
  82     my $self = shift @_;
  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';
  90     }
  91 }
  92
  93 =head2 isa
  94
  95 handle $self->isa since AUTOLOAD can't.
  96
  97 =cut
  98
  99 sub isa {
 100     my ($self, $target) = @_;
 101     if(defined $target) {
 102         if(blessed $self) {
 103                 return $self->__type_constraint->isa($target);
 104         } else {
 105                 return;
 106         }
 107     } else {
 108         return;
 109     }
 110 }
 111
 112 =head2 can
 113
 114 handle $self->can since AUTOLOAD can't.
 115
 116 =cut
 117
 118 sub can {
 119     my ($self, $target) = @_;
 120     if(defined $target) {
 121         if(blessed $self) {
 122                 return $self->__type_constraint->can($target);
 123         } else {
 124                 return;
 125         }
 126     } else {
 127         return;
 128     }
 129 }
 130
 131 =head2 meta
 132
 133 have meta examine the underlying type constraints
 134
 135 =cut
 136
 137 sub meta {
 138         my $self = shift @_;
 139         if(blessed $self) {
 140                 return $self->__type_constraint->meta;
 141         }
 142 }
 143
 144
 145 =head2 DESTROY
 146
 147 We might need it later
 148
 149 =cut
 150
 151 sub DESTROY {
 152     return;
 153 }
 154
 155 =head2 AUTOLOAD
 156
 157 Delegate to the decorator targe
 158
 159 =cut
 160
 161 sub AUTOLOAD {
 162
 163     my ($self, @args) = @_;
 164     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 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 $@;
 176     } else {
 177         return $return;
 178     }
 179 }
 180
 181 =head1 AUTHOR AND COPYRIGHT
 182
 183 John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
 184
 185 =head1 LICENSE
 186
 187 This program is free software; you can redistribute it and/or modify
 188 it under the same terms as perl itself.
 189
 190 =cut
 191
 192 1;