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 call the class' version of the method if present, and fall
 162 back to the type's version if not.
 163
 164 =cut
 165
 166 sub AUTOLOAD {
 167     my ($self, @args) = @_;
 168     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 169
 170     ## We delegate with this method in an attempt to support a value of
 171     ## __type_constraint which is also AUTOLOADing, in particular the class
 172     ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
 173
 174     $self->_try_delegate($method, @args);
 175 }
 176
 177 sub _try_delegate {
 178     my ($self, $method, @args) = @_;
 179     my $tc = $self->__type_constraint;
 180     my $class;
 181     if ($tc->can('is_subtype_of')) { # Union can't
 182         my $search_tc = $tc;
 183         while (1) {
 184             if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
 185                 $class = $search_tc->class;
 186                 last;
 187             }
 188             $search_tc = $search_tc->parent;
 189             last unless $search_tc->is_subtype_of('Object');
 190         }
 191     }
 192
 193     my $inv = ($class && $class->can($method)) ? $class : $tc;
 194
 195     $inv->$method(@args);
 196 }
 197
 198 =head1 LICENSE
 199
 200 This program is free software; you can redistribute it and/or modify
 201 it under the same terms as perl itself.
 202
 203 =cut
 204
 205 1;