lib/MooseX/Types/TypeDecorator.pm

   1 package MooseX::Types::TypeDecorator;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp::Clan qw( ^MooseX::Types );
   7 use Moose::Util::TypeConstraints ();
   8 use Moose::Meta::TypeConstraint::Union;
   9 use Scalar::Util qw(blessed);
  10
  11 use overload(
  12     '""' => sub {
  13         return shift->__type_constraint->name;
  14     },
  15     '|' => sub {
  16
  17         ## It's kind of ugly that we need to know about Union Types, but this
  18         ## is needed for syntax compatibility.  Maybe someday we'll all just do
  19         ## Or[Str,Str,Int]
  20
  21         my @tc = grep {blessed $_} @_;
  22         my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
  23         return Moose::Util::TypeConstraints::register_type_constraint($union);
  24     },
  25     fallback => 1,
  26
  27 );
  28
  29
  30 =head1 NAME
  31
  32 MooseX::Types::TypeDecorator - More flexible access to a Type Constraint
  33
  34 =head1 DESCRIPTION
  35
  36 This is a decorator object that contains an underlying type constraint.  We use
  37 this to control access to the type constraint and to add some features.
  38
  39 =head1 METHODS
  40
  41 This class defines the following methods.
  42
  43 =head2 new
  44
  45 Old school instantiation
  46
  47 =cut
  48
  49 sub new {
  50     my $class = shift @_;
  51     if(my $arg = shift @_) {
  52         if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
  53             return bless {'__type_constraint'=>$arg}, $class;
  54         } elsif(
  55             blessed $arg &&
  56             $arg->isa('MooseX::Types::UndefinedType')
  57           ) {
  58             ## stub in case we'll need to handle these types differently
  59             return bless {'__type_constraint'=>$arg}, $class;
  60         } elsif(blessed $arg) {
  61             croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
  62         } else {
  63             croak "Argument cannot be '$arg'";
  64         }
  65     } else {
  66         croak "This method [new] requires a single argument.";
  67     }
  68 }
  69
  70 =head __type_constraint ($type_constraint)
  71
  72 Set/Get the type_constraint.
  73
  74 =cut
  75
  76 sub __type_constraint {
  77     my $self = shift @_;
  78
  79     if(blessed $self) {
  80         if(defined(my $tc = shift @_)) {
  81             $self->{__type_constraint} = $tc;
  82         }
  83         return $self->{__type_constraint};
  84     } else {
  85         croak 'cannot call __type_constraint as a class method';
  86     }
  87 }
  88
  89 =head2 isa
  90
  91 handle $self->isa since AUTOLOAD can't.
  92
  93 =cut
  94
  95 sub isa {
  96     my ($self, $target) = @_;
  97     if(defined $target) {
  98         return $self->__type_constraint->isa($target);
  99     } else {
 100         return;
 101     }
 102 }
 103
 104 =head2 can
 105
 106 handle $self->can since AUTOLOAD can't.
 107
 108 =cut
 109
 110 sub can {
 111     my ($self, $target) = @_;
 112     if(defined $target) {
 113         return $self->__type_constraint->can($target);
 114     } else {
 115         return;
 116     }
 117 }
 118
 119 =head2 DESTROY
 120
 121 We might need it later
 122
 123 =cut
 124
 125 sub DESTROY {
 126     return;
 127 }
 128
 129 =head2 AUTOLOAD
 130
 131 Delegate to the decorator targe
 132
 133 =cut
 134
 135 sub AUTOLOAD {
 136     my ($self, @args) = @_;
 137     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 138     if($self->__type_constraint->can($method)) {
 139         return $self->__type_constraint->$method(@args);
 140     } else {
 141         croak "Method '$method' is not supported for ". ref($self->__type_constraint);
 142     }
 143 }
 144
 145 =head1 AUTHOR AND COPYRIGHT
 146
 147 John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
 148
 149 =head1 LICENSE
 150
 151 This program is free software; you can redistribute it and/or modify
 152 it under the same terms as perl itself.
 153
 154 =cut
 155
 156 1;