lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm

   1 package ## Hide from PAUSE
   2  MooseX::Dependent::Meta::TypeConstraint::Dependent;
   3
   4 use Moose;
   5 use Moose::Util::TypeConstraints ();
   6 use Scalar::Util qw(blessed);
   7
   8 extends 'Moose::Meta::TypeConstraint';
   9
  10 =head1 NAME
  11
  12 MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
  13
  14 =head1 DESCRIPTION
  15
  16 see L<MooseX::Dependent> for examples and details of how to use dependent
  17 types.  This class is a subclass of L<Moose::Meta::TypeConstraint> which
  18 provides the gut functionality to enable dependent type constraints.
  19
  20 =head1 ATTRIBUTES
  21
  22 This class defines the following attributes.
  23
  24 =head2 parent_type_constraint
  25
  26 The type constraint whose validity is being made dependent.
  27
  28 =cut
  29
  30 has 'parent_type_constraint' => (
  31     is=>'ro',
  32     isa=>'Object',
  33     default=> sub {
  34         Moose::Util::TypeConstraints::find_type_constraint("Any");
  35     },
  36     required=>1,
  37 );
  38
  39
  40 =head2 constraining_value_type_constraint
  41
  42 This is a type constraint which defines what kind of value is allowed to be the
  43 constraining value of the dependent type.
  44
  45 =cut
  46
  47 has 'constraining_value_type_constraint' => (
  48     is=>'ro',
  49     isa=>'Object',
  50     default=> sub {
  51         Moose::Util::TypeConstraints::find_type_constraint("Any");
  52     },
  53     required=>1,
  54 );
  55
  56 =head2 constraining_value
  57
  58 This is the actual value that constraints the L</parent_type_constraint>
  59
  60 =cut
  61
  62 has 'constraining_value' => (
  63     is=>'ro',
  64     predicate=>'has_constraining_value',
  65 );
  66
  67 =head1 METHODS
  68
  69 This class defines the following methods.
  70
  71 =head2 parameterize (@args)
  72
  73 Given a ref of type constraints, create a structured type.
  74
  75 =cut
  76
  77 sub parameterize {
  78     my $self = shift @_;
  79     my $class = ref $self;
  80
  81     Moose->throw_error("$self already has a constraining value.") if
  82      $self->has_constraining_value;
  83
  84     if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
  85         my $arg1 = shift @_;
  86
  87         if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
  88             my $arg2 = shift @_ || $self->constraining_value_type_constraint;
  89
  90             ## TODO fix this crap!
  91             Moose->throw_error("$arg2 is not a type constraint")
  92              unless $arg2->isa('Moose::Meta::TypeConstraint');
  93
  94             Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
  95              unless $arg1->is_a_type_of($self->parent_type_constraint);
  96
  97             Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
  98              unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
  99
 100             Moose->throw_error('Too Many Args!  Two are allowed.') if @_;
 101
 102             return $class->new(
 103                 name => $self->_generate_subtype_name($arg1, $arg2),
 104                 parent => $self,
 105                 constraint => $self->constraint,
 106                 parent_type_constraint=>$arg1,
 107                 constraining_value_type_constraint => $arg2,
 108             );
 109         } else {
 110             Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
 111              unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
 112
 113             return $class->new(
 114                 name => $self->_generate_subtype_name($self->parent_type_constraint, $arg1),
 115                 parent => $self,
 116                 constraint => $self->constraint,
 117                 parent_type_constraint=>$self->parent_type_constraint,
 118                 constraining_value_type_constraint => $arg1,
 119             );
 120         }
 121     } else {
 122         my $args;
 123         ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
 124         if(@_) {
 125             if($#_) {
 126                 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
 127                     $args = {@_};
 128                 } else {
 129                     $args = [@_];
 130                 }
 131             } else {
 132                 $args = $_[0];
 133             }
 134
 135         } else {
 136             ## TODO:  Is there a use case for parameterizing null or undef?
 137             Moose->throw_error('Cannot Parameterize null values.');
 138         }
 139
 140         if(my $err = $self->constraining_value_type_constraint->validate($args)) {
 141             Moose->throw_error($err);
 142         } else {
 143             ## TODO memorize or do a registry lookup on the name as an optimization
 144             return $class->new(
 145                 name => $self->name."[$args]",
 146                 parent => $self,
 147                 constraint => $self->constraint,
 148                 constraining_value => $args,
 149                 parent_type_constraint=>$self->parent_type_constraint,
 150                 constraining_value_type_constraint => $self->constraining_value_type_constraint,
 151             );
 152         }
 153     }
 154 }
 155
 156 =head2 _generate_subtype_name
 157
 158 Returns a name for the dependent type that should be unique
 159
 160 =cut
 161
 162 sub _generate_subtype_name {
 163     my ($self, $parent_tc, $constraining_tc) = @_;
 164     return sprintf(
 165         $self."[%s, %s]",
 166         $parent_tc, $constraining_tc,
 167     );
 168 }
 169
 170 =head2 create_child_type
 171
 172 modifier to make sure we get the constraint_generator
 173
 174 =cut
 175
 176 around 'create_child_type' => sub {
 177     my ($create_child_type, $self, %opts) = @_;
 178     if($self->has_constraining_value) {
 179         $opts{constraining_value} = $self->constraining_value;
 180     }
 181     return $self->$create_child_type(
 182         %opts,
 183         parent=> $self,
 184         parent_type_constraint=>$self->parent_type_constraint,
 185         constraining_value_type_constraint => $self->constraining_value_type_constraint,
 186     );
 187 };
 188
 189 =head2 equals ($type_constraint)
 190
 191 Override the base class behavior so that a dependent type equal both the parent
 192 type and the overall dependent container.  This behavior may change if we can
 193 figure out what a dependent type is (multiply inheritance or a role...)
 194
 195 =cut
 196
 197 around 'equals' => sub {
 198     my ( $equals, $self, $type_or_name ) = @_;
 199
 200     my $other = defined $type_or_name ?
 201       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 202       Moose->throw_error("Can't call $self ->equals without a parameter");
 203
 204     Moose->throw_error("$type_or_name is not a registered Type")
 205      unless $other;
 206
 207     if(my $parent = $other->parent) {
 208         return $self->$equals($other)
 209          || $self->parent->equals($parent);
 210     } else {
 211         return $self->$equals($other);
 212     }
 213 };
 214
 215 around 'is_subtype_of' => sub {
 216     my ( $is_subtype_of, $self, $type_or_name ) = @_;
 217
 218     my $other = defined $type_or_name ?
 219       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 220       Moose->throw_error("Can't call $self ->equals without a parameter");
 221
 222     Moose->throw_error("$type_or_name is not a registered Type")
 223      unless $other;
 224
 225     return $self->$is_subtype_of($other)
 226         || $self->parent_type_constraint->is_subtype_of($other);
 227
 228 };
 229
 230 sub is_a_type_of {
 231     my ($self, @args) = @_;
 232     return ($self->equals(@args) ||
 233       $self->is_subtype_of(@args));
 234 }
 235
 236 around 'check' => sub {
 237     my ($check, $self, @args) = @_;
 238     return (
 239         $self->parent_type_constraint->check(@args) &&
 240         $self->$check(@args)
 241     );
 242 };
 243
 244 around 'validate' => sub {
 245     my ($validate, $self, @args) = @_;
 246     return (
 247         $self->parent_type_constraint->validate(@args) ||
 248         $self->$validate(@args)
 249     );
 250 };
 251
 252 around '_compiled_type_constraint' => sub {
 253     my ($method, $self, @args) = @_;
 254     my $coderef = $self->$method(@args);
 255     my $constraining;
 256     if($self->has_constraining_value) {
 257         $constraining = $self->constraining_value;
 258     }
 259
 260     return sub {
 261         my @local_args = @_;
 262         if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
 263             Moose->throw_error($err);
 264         }
 265         $coderef->(@local_args, $constraining);
 266     };
 267 };
 268
 269 =head2 get_message
 270
 271 Give you a better peek into what's causing the error.
 272
 273 around 'get_message' => sub {
 274     my ($get_message, $self, $value) = @_;
 275     return $self->$get_message($value);
 276 };
 277
 278 =head1 SEE ALSO
 279
 280 The following modules or resources may be of interest.
 281
 282 L<Moose>, L<Moose::Meta::TypeConstraint>
 283
 284 =head1 AUTHOR
 285
 286 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 287
 288 =head1 COPYRIGHT & LICENSE
 289
 290 This program is free software; you can redistribute it and/or modify
 291 it under the same terms as Perl itself.
 292
 293 =cut
 294
 295 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 296