lib/MooseX/Types/TypeDecorator.pm

   1 package MooseX::Types::TypeDecorator;
   2
   3 #ABSTRACT: Wraps Moose::Meta::TypeConstraint objects with added features
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp::Clan qw( ^MooseX::Types );
   9 use Moose::Util::TypeConstraints ();
  10 use Moose::Meta::TypeConstraint::Union;
  11 use Scalar::Util qw(blessed);
  12
  13 use overload(
  14     '0+' => sub {
  15             my $self = shift @_;
  16             my $tc = $self->{__type_constraint};
  17             return 0+$tc;
  18      },
  19     '""' => sub {
  20                 my $self = shift @_;
  21                 if(blessed $self) {
  22                         return $self->__type_constraint->name;
  23                 } else {
  24                         return "$self";
  25                 }
  26     },
  27     bool => sub { 1 },
  28     '|' => sub {
  29
  30         ## It's kind of ugly that we need to know about Union Types, but this
  31         ## is needed for syntax compatibility.  Maybe someday we'll all just do
  32         ## Or[Str,Str,Int]
  33
  34         my @args = @_[0,1]; ## arg 3 is special,  see the overload docs.
  35         my @tc = grep {blessed $_} map {
  36             blessed $_ ? $_ :
  37             Moose::Util::TypeConstraints::find_or_parse_type_constraint($_)
  38               || __PACKAGE__->_throw_error( "$_ is not a type constraint")
  39         } @args;
  40
  41         ( scalar @tc == scalar @args)
  42             || __PACKAGE__->_throw_error(
  43                           "one of your type constraints is bad.  Passed: ". join(', ', @args) ." Got: ". join(', ', @tc));
  44
  45         ( scalar @tc >= 2 )
  46             || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
  47
  48         my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
  49         return Moose::Util::TypeConstraints::register_type_constraint($union);
  50     },
  51     fallback => 1,
  52
  53 );
  54
  55 =head1 DESCRIPTION
  56
  57 This is a decorator object that contains an underlying type constraint.  We use
  58 this to control access to the type constraint and to add some features.
  59
  60 =head1 METHODS
  61
  62 This class defines the following methods.
  63
  64 =head2 new
  65
  66 Old school instantiation
  67
  68 =cut
  69
  70 sub new {
  71     my $proto = shift;
  72     if (ref($proto)) {
  73         return $proto->_try_delegate('new', @_);
  74     }
  75     my $class = $proto;
  76     if(my $arg = shift @_) {
  77         if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
  78             return bless {'__type_constraint'=>$arg}, $class;
  79         } elsif(
  80             blessed $arg &&
  81             $arg->isa('MooseX::Types::UndefinedType')
  82           ) {
  83             ## stub in case we'll need to handle these types differently
  84             return bless {'__type_constraint'=>$arg}, $class;
  85         } elsif(blessed $arg) {
  86             __PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg);
  87         } else {
  88             __PACKAGE__->_throw_error("Argument cannot be '$arg'");
  89         }
  90     } else {
  91         __PACKAGE__->_throw_error("This method [new] requires a single argument.");
  92     }
  93 }
  94
  95 =head2 __type_constraint ($type_constraint)
  96
  97 Set/Get the type_constraint.
  98
  99 =cut
 100
 101 sub __type_constraint {
 102     my $self = shift @_;
 103     if(blessed $self) {
 104         if(defined(my $tc = shift @_)) {
 105             $self->{__type_constraint} = $tc;
 106         }
 107         return $self->{__type_constraint};
 108     } else {
 109         __PACKAGE__->_throw_error('cannot call __type_constraint as a class method');
 110     }
 111 }
 112
 113 =head2 isa
 114
 115 handle $self->isa since AUTOLOAD can't - this tries both the type constraint,
 116 and for a class type, the class.
 117
 118 =cut
 119
 120 sub isa {
 121   my $self = shift;
 122   return
 123     blessed $self
 124       ? $self->__type_constraint->isa(@_)
 125       || $self->_try_delegate( 'isa', @_ )
 126       : $self->SUPER::isa(@_);
 127 }
 128
 129 =head2 can
 130
 131 handle $self->can since AUTOLOAD can't.
 132
 133 =cut
 134
 135 sub can {
 136     my $self = shift;
 137
 138     return blessed $self
 139         ? $self->_try_delegate( 'can', @_ )
 140         : $self->SUPER::can(@_);
 141 }
 142
 143 =head2 _throw_error
 144
 145 properly delegate error messages
 146
 147 =cut
 148
 149 sub _throw_error {
 150     shift;
 151     require Moose;
 152     unshift @_, 'Moose';
 153     goto &Moose::throw_error;
 154 }
 155
 156 =head2 DESTROY
 157
 158 We might need it later
 159
 160 =cut
 161
 162 sub DESTROY {
 163     return;
 164 }
 165
 166 =head2 AUTOLOAD
 167
 168 Delegate to the decorator target, unless this is a class type, in which
 169 case it will try to delegate to the type object, then if that fails try
 170 the class. The method 'new' is special cased to only be permitted on
 171 the class; if there is no class, or it does not provide a new method,
 172 an exception will be thrown.
 173
 174 =cut
 175
 176 sub AUTOLOAD {
 177     my ($self, @args) = @_;
 178     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 179
 180     ## We delegate with this method in an attempt to support a value of
 181     ## __type_constraint which is also AUTOLOADing, in particular the class
 182     ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
 183
 184     $self->_try_delegate($method, @args);
 185 }
 186
 187 sub _try_delegate {
 188     my ($self, $method, @args) = @_;
 189     my $tc = $self->__type_constraint;
 190     my $class;
 191     if ($tc->can('is_subtype_of')) { # Union can't
 192         my $search_tc = $tc;
 193         while (1) {
 194             if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
 195                 $class = $search_tc->class;
 196                 last;
 197             }
 198             $search_tc = $search_tc->parent;
 199             last unless $search_tc && $search_tc->is_subtype_of('Object');
 200         }
 201     }
 202
 203     my $inv = do {
 204         if ($method eq 'new') {
 205             die "new called on type decorator for non-class-type ".$tc->name
 206                 unless $class;
 207             die "new called on class type decorator ".$tc->name."\n"
 208                 ." for class ${class}\n"
 209                 ." which does not provide a new method - did you forget to load it?"
 210                 unless $class->can('new');
 211             $class
 212         } elsif ($class && !$tc->can($method)) {
 213             $class
 214         } else {
 215             $tc
 216         }
 217     };
 218
 219     $inv->$method(@args);
 220 }
 221
 222 =head1 LICENSE
 223
 224 This program is free software; you can redistribute it and/or modify
 225 it under the same terms as perl itself.
 226
 227 =cut
 228
 229 1;