lib/MooseX/Types/Dependent.pm

   1 package MooseX::Types::Dependent;
   2
   3 use strict;
   4 use warnings;
   5
   6
   7 #use Carp::Clan qw( ^MooseX::Types );
   8 use Moose::Util::TypeConstraints ();
   9 use Scalar::Util qw(blessed);
  10
  11 use overload(
  12     '""' => sub {
  13                 my $self = shift @_;
  14                 if(blessed $self) {
  15                         return $self->__internal_type_constraint->name;
  16                 } else {
  17                         return "$self";
  18                 }
  19     },
  20     fallback => 1,
  21 );
  22
  23 =head1 NAME
  24
  25 MooseX::Types::Dependent - Type Constraints that are dependent on others
  26
  27 =head1 SYNOPSIS
  28
  29     use MooseX::Types::Dependent;
  30
  31     ## Assuming the type constraint 'Set' isa Set::Scalar
  32
  33     subtype UniqueInt,
  34       as Dependent[Int,Set],
  35       where {
  36         ## ok Set->check($set), 'Good $set';
  37         ## ok Int->check($val), 'Already an Int'
  38         my ($set, $val) = @_;
  39         ## If the $set already has $val, then it's not unique
  40         return $set->has($val) ? 0:1
  41       };
  42
  43     my $set = Set::Scalar->new(1..10);
  44
  45     ok UniqueInt->check([1, $set]);  ## Fails, 1 is already in $set;
  46     ok UniqueInt->check(['a', $set]); ## Fails, 'a' is not an Int;
  47     ok UniqueInt->check([1, $obj]); ## Fails, $obj is not a Set;
  48     ok UniqueInt->check([20, $set]); ## PASSES
  49
  50 =head1 DESCRIPTION
  51
  52 This is a decorator object that contains an underlying type constraint.  We use
  53 this to control access to the type constraint and to add some features.
  54
  55 =head1 METHODS
  56
  57 This class defines the following methods.
  58
  59 =head2 new
  60
  61 Old school instantiation
  62
  63 =cut
  64
  65 sub new {
  66     my $class = shift @_;
  67     my $attributes = {};
  68     if(my $
  69     if(my $arg = shift @_) {
  70         if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
  71             return bless {'__type_constraint'=>$arg}, $class;
  72         } elsif(
  73             blessed $arg &&
  74             $arg->isa('MooseX::Types::UndefinedType')
  75           ) {
  76             ## stub in case we'll need to handle these types differently
  77             return bless {'__type_constraint'=>$arg}, $class;
  78         } elsif(blessed $arg) {
  79             croak "Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg;
  80         } else {
  81             croak "Argument cannot be '$arg'";
  82         }
  83     } else {
  84         croak "This method [new] requires a single argument.";
  85     }
  86 }
  87
  88 =head2 __internal_type_constraint ($type_constraint)
  89
  90 Set/Get the type_constraint we are making dependent.
  91
  92 =cut
  93
  94 sub __internal_type_constraint {
  95     my $self = shift @_;
  96     if(blessed $self) {
  97         if(defined(my $tc = shift @_)) {
  98             $self->{__type_constraint} = $tc;
  99         }
 100         return $self->{__type_constraint};
 101     } else {
 102         croak 'cannot call __internal_type_constraint as a class method';
 103     }
 104 }
 105
 106 =head2 isa
 107
 108 handle $self->isa since AUTOLOAD can't.
 109
 110 =cut
 111
 112 sub isa {
 113     my ($self, $target) = @_;
 114     if(defined $target) {
 115         if(blessed $self) {
 116                 return $self->__internal_type_constraint->isa($target);
 117         } else {
 118                 return;
 119         }
 120     } else {
 121         return;
 122     }
 123 }
 124
 125 =head2 can
 126
 127 handle $self->can since AUTOLOAD can't.
 128
 129 =cut
 130
 131 sub can {
 132     my ($self, $target) = @_;
 133     if(defined $target) {
 134         if(blessed $self) {
 135                 return $self->__internal_type_constraint->can($target);
 136         } else {
 137                 return;
 138         }
 139     } else {
 140         return;
 141     }
 142 }
 143
 144 =head2 meta
 145
 146 have meta examine the underlying type constraints
 147
 148 =cut
 149
 150 sub meta {
 151         my $self = shift @_;
 152         if(blessed $self) {
 153                 return $self->__internal_type_constraint->meta;
 154         }
 155 }
 156
 157
 158 =head2 DESTROY
 159
 160 We might need it later
 161
 162 =cut
 163
 164 sub DESTROY {
 165     return;
 166 }
 167
 168 =head2 AUTOLOAD
 169
 170 Delegate to the decorator targe
 171
 172 =cut
 173
 174 sub AUTOLOAD {
 175
 176     my ($self, @args) = @_;
 177     my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
 178
 179     ## We delegate with this method in an attempt to support a value of
 180     ## __type_constraint which is also AUTOLOADing, in particular the class
 181     ## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
 182
 183     my $return;
 184
 185     eval {
 186         $return = $self->__internal_type_constraint->$method(@args);
 187     }; if($@) {
 188         croak $@;
 189     } else {
 190         return $return;
 191     }
 192 }
 193
 194 =head1 AUTHOR AND COPYRIGHT
 195
 196 John Napiorkowski (jnapiorkowski) <jjnapiork@cpan.org>
 197
 198 =head1 LICENSE
 199
 200 This program is free software; you can redistribute it and/or modify
 201 it under the same terms as perl itself.
 202
 203 =cut
 204
 205 1;
 206