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