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