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, %args) = @_;
  42     if(
  43         $args{type_constraint} && ref($args{type_constraint}) &&
  44         ($args{type_constraint}->isa('Moose::Meta::TypeConstraint') ||
  45         $args{type_constraint}->isa('MooseX::Types::UndefinedType'))
  46     ) {
  47         return bless \%args, $class;
  48     } else {
  49         croak "The argument 'type_constraint' is not valid.";
  50     }
  51
  52 }
  53
  54 =head type_constraint ($type_constraint)
  55
  56 Set/Get the type_constraint.
  57
  58 =cut
  59
  60 sub type_constraint {
  61     my $self = shift @_;
  62     if(defined(my $tc = shift @_)) {
  63         $self->{type_constraint} = $tc;
  64     }
  65     return $self->{type_constraint};
  66 }
  67
  68 =head2 isa
  69
  70 handle $self->isa since AUTOLOAD can't.
  71
  72 =cut
  73
  74 sub isa {
  75     my ($self, $target) = @_;
  76     if(defined $target) {
  77         my $isa = $self->type_constraint->isa($target);
  78         return $isa;
  79     } else {
  80         return;
  81     }
  82 }
  83
  84 =head2 can
  85
  86 handle $self->can since AUTOLOAD can't.
  87
  88 =cut
  89
  90 sub can {
  91     my ($self, $target) = @_;
  92     if(defined $target) {
  93         my $can = $self->type_constraint->can($target);
  94         return $can;
  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 ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 118     return shift->type_constraint->$method(@_);
 119 }
 120
 121 =head1 AUTHOR AND COPYRIGHT
 122
 123 John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
 124
 125 =head1 LICENSE
 126
 127 This program is free software; you can redistribute it and/or modify
 128 it under the same terms as perl itself.
 129
 130 =cut
 131
 132 1;