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(blessed $arg && $arg->isa('MooseX::Types::UndefinedType')) {
  55             ## stub in case we'll need to handle these types differently
  56             return bless {'__type_constraint'=>$arg}, $class;
  57         } elsif(blessed $arg) {
  58             croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
  59         } else {
  60             croak "Argument cannot be '$arg'";
  61         }
  62     } else {
  63         croak "This method [new] requires a single argument of 'arg'.";
  64     }
  65 }
  66
  67 =head __type_constraint ($type_constraint)
  68
  69 Set/Get the type_constraint.
  70
  71 =cut
  72
  73 sub __type_constraint {
  74     my $self = shift @_;
  75
  76     if(blessed $self) {
  77         if(defined(my $tc = shift @_)) {
  78             $self->{__type_constraint} = $tc;
  79         }
  80         return $self->{__type_constraint};
  81     } else {
  82         croak 'cannot call __type_constraint as a class method';
  83     }
  84 }
  85
  86 =head2 isa
  87
  88 handle $self->isa since AUTOLOAD can't.
  89
  90 =cut
  91
  92 sub isa {
  93     my ($self, $target) = @_;
  94     if(defined $target) {
  95         return $self->__type_constraint->isa($target);
  96     } else {
  97         return;
  98     }
  99 }
 100
 101 =head2 can
 102
 103 handle $self->can since AUTOLOAD can't.
 104
 105 =cut
 106
 107 sub can {
 108     my ($self, $target) = @_;
 109     if(defined $target) {
 110         return $self->__type_constraint->can($target);
 111     } else {
 112         return;
 113     }
 114 }
 115
 116 =head2 DESTROY
 117
 118 We might need it later
 119
 120 =cut
 121
 122 sub DESTROY {
 123     return;
 124 }
 125
 126 =head2 AUTOLOAD
 127
 128 Delegate to the decorator targe
 129
 130 =cut
 131
 132 sub AUTOLOAD {
 133     my ($self, @args) = @_;
 134     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 135     if($self->__type_constraint->can($method)) {
 136         return $self->__type_constraint->$method(@args);
 137     } else {
 138         croak "Method '$method' is not supported";
 139     }
 140 }
 141
 142 =head1 AUTHOR AND COPYRIGHT
 143
 144 John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
 145
 146 =head1 LICENSE
 147
 148 This program is free software; you can redistribute it and/or modify
 149 it under the same terms as perl itself.
 150
 151 =cut
 152
 153 1;