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 only be permitted on
 163 the class; if there is no class, or it does not provide a new method,
 164 an exception will be thrown.
 165
 166 =cut
 167
 168 sub AUTOLOAD {
 169     my ($self, @args) = @_;
 170     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 171
 172     ## We delegate with this method in an attempt to support a value of
 173     ## __type_constraint which is also AUTOLOADing, in particular the class
 174     ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
 175
 176     $self->_try_delegate($method, @args);
 177 }
 178
 179 sub _try_delegate {
 180     my ($self, $method, @args) = @_;
 181     my $tc = $self->__type_constraint;
 182     my $class;
 183     if ($tc->can('is_subtype_of')) { # Union can't
 184         my $search_tc = $tc;
 185         while (1) {
 186             if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
 187                 $class = $search_tc->class;
 188                 last;
 189             }
 190             $search_tc = $search_tc->parent;
 191             last unless $search_tc && $search_tc->is_subtype_of('Object');
 192         }
 193     }
 194
 195     my $inv = do {
 196         if ($method eq 'new') {
 197             die "new called on type decorator for non-class-type ".$tc->name
 198                 unless $class;
 199             die "new called on class type decorator ".$tc->name."\n"
 200                 ." for class ${class}\n"
 201                 ." which does not provide a new method - did you forget to load it?"
 202                 unless $class->can('new');
 203             $class
 204         } elsif ($class && !$tc->can($method)) {
 205             $class
 206         } else {
 207             $tc
 208         }
 209     };
 210
 211     $inv->$method(@args);
 212 }
 213
 214 =head1 LICENSE
 215
 216 This program is free software; you can redistribute it and/or modify
 217 it under the same terms as perl itself.
 218
 219 =cut
 220
 221 1;