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     $self->__type_constraint->isa(@_)
 124     || $self->_try_delegate('isa', @_);
 125 }
 126
 127 =head2 can
 128
 129 handle $self->can since AUTOLOAD can't.
 130
 131 =cut
 132
 133 sub can { shift->_try_delegate('can', @_) }
 134
 135 =head2 _throw_error
 136
 137 properly delegate error messages
 138
 139 =cut
 140
 141 sub _throw_error {
 142     shift;
 143     require Moose;
 144     unshift @_, 'Moose';
 145     goto &Moose::throw_error;
 146 }
 147
 148 =head2 DESTROY
 149
 150 We might need it later
 151
 152 =cut
 153
 154 sub DESTROY {
 155     return;
 156 }
 157
 158 =head2 AUTOLOAD
 159
 160 Delegate to the decorator target, unless this is a class type, in which
 161 case it will try to delegate to the type object, then if that fails try
 162 the class. The method 'new' is special cased to go to the class first
 163 if present.
 164
 165 =cut
 166
 167 sub AUTOLOAD {
 168     my ($self, @args) = @_;
 169     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 170
 171     ## We delegate with this method in an attempt to support a value of
 172     ## __type_constraint which is also AUTOLOADing, in particular the class
 173     ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
 174
 175     $self->_try_delegate($method, @args);
 176 }
 177
 178 sub _try_delegate {
 179     my ($self, $method, @args) = @_;
 180     my $tc = $self->__type_constraint;
 181     my $class;
 182     if ($tc->can('is_subtype_of')) { # Union can't
 183         my $search_tc = $tc;
 184         while (1) {
 185             if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
 186                 $class = $search_tc->class;
 187                 last;
 188             }
 189             $search_tc = $search_tc->parent;
 190             last unless $search_tc->is_subtype_of('Object');
 191         }
 192     }
 193
 194     my $inv = do {
 195       if ($tc->can($method) and $method ne 'new') {
 196             $tc
 197         } elsif ($class && $class->can($method)) {
 198             $class
 199         } else {
 200             $tc
 201         }
 202     };
 203
 204     $inv->$method(@args);
 205 }
 206
 207 =head1 LICENSE
 208
 209 This program is free software; you can redistribute it and/or modify
 210 it under the same terms as perl itself.
 211
 212 =cut
 213
 214 1;