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