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