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