lib/MooseX/Types/TypeDecorator.pm

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