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