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 ## Right now I add in the dependent type coercion until I can merge some Moose
  81 ## changes upstream
  82
  83 around 'new' => sub {
  84     my ($new, $class, @args) = @_;
  85     my $self = $class->$new(@args);
  86     my $coercion = MooseX::Dependent::Meta::TypeCoercion::Dependent->new(type_constraint => $self);
  87     $self->coercion($coercion);
  88     return $self;
  89 };
  90
  91 =head2 parameterize (@args)
  92
  93 Given a ref of type constraints, create a structured type.
  94
  95 =cut
  96
  97 sub parameterize {
  98     my $self = shift @_;
  99     my $class = ref $self;
 100
 101     Moose->throw_error("$self already has a constraining value.") if
 102      $self->has_constraining_value;
 103
 104     if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
 105         my $arg1 = shift @_;
 106
 107         if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
 108             my $arg2 = shift @_ || $self->constraining_value_type_constraint;
 109
 110             ## TODO fix this crap!
 111             Moose->throw_error("$arg2 is not a type constraint")
 112              unless $arg2->isa('Moose::Meta::TypeConstraint');
 113
 114             Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
 115              unless $arg1->is_a_type_of($self->parent_type_constraint);
 116
 117             Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
 118              unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
 119
 120             Moose->throw_error('Too Many Args!  Two are allowed.') if @_;
 121
 122             my $name = $self->_generate_subtype_name($arg1, $arg2);
 123             if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
 124                 return $exists;
 125             } else {
 126                 my $type_constraint = $class->new(
 127                     name => $name,
 128                     parent => $self,
 129                     constraint => $self->constraint,
 130                     parent_type_constraint=>$arg1,
 131                     constraining_value_type_constraint => $arg2,
 132                 );
 133                 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 134                 return $type_constraint;
 135             }
 136         } else {
 137             Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
 138              unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
 139
 140             my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
 141             if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
 142                 return $exists;
 143             } else {
 144                 my $type_constraint = $class->new(
 145                     name => $name,
 146                     parent => $self,
 147                     constraint => $self->constraint,
 148                     parent_type_constraint=>$self->parent_type_constraint,
 149                     constraining_value_type_constraint => $arg1,
 150                 );
 151                 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 152                 return $type_constraint;
 153             }
 154         }
 155     } else {
 156         my $args;
 157         ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
 158         if(@_) {
 159             if($#_) {
 160                 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
 161                     $args = {@_};
 162                 } else {
 163                     $args = [@_];
 164                 }
 165             } else {
 166                 $args = $_[0];
 167             }
 168
 169         } else {
 170             ## TODO:  Is there a use case for parameterizing null or undef?
 171             Moose->throw_error('Cannot Parameterize null values.');
 172         }
 173
 174         if(my $err = $self->constraining_value_type_constraint->validate($args)) {
 175             Moose->throw_error($err);
 176         } else {
 177
 178             my $sig = $args;
 179             if(ref $sig) {
 180                 $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
 181             }
 182             my $name = $self->name."[$sig]";
 183             if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
 184                 return $exists;
 185             } else {
 186                 my $type_constraint = $class->new(
 187                     name => $name,
 188                     parent => $self,
 189                     constraint => $self->constraint,
 190                     constraining_value => $args,
 191                     parent_type_constraint=>$self->parent_type_constraint,
 192                     constraining_value_type_constraint => $self->constraining_value_type_constraint,
 193                 );
 194
 195                 ## TODO This is probably going to have to go away (too many things added to the registry)
 196                 ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 197                 return $type_constraint;
 198             }
 199         }
 200     }
 201 }
 202
 203 =head2 _generate_subtype_name
 204
 205 Returns a name for the dependent type that should be unique
 206
 207 =cut
 208
 209 sub _generate_subtype_name {
 210     my ($self, $parent_tc, $constraining_tc) = @_;
 211     return sprintf(
 212         $self."[%s, %s]",
 213         $parent_tc, $constraining_tc,
 214     );
 215 }
 216
 217 =head2 create_child_type
 218
 219 modifier to make sure we get the constraint_generator
 220
 221 =cut
 222
 223 around 'create_child_type' => sub {
 224     my ($create_child_type, $self, %opts) = @_;
 225     if($self->has_constraining_value) {
 226         $opts{constraining_value} = $self->constraining_value;
 227     }
 228     return $self->$create_child_type(
 229         %opts,
 230         parent=> $self,
 231         parent_type_constraint=>$self->parent_type_constraint,
 232         constraining_value_type_constraint => $self->constraining_value_type_constraint,
 233     );
 234 };
 235
 236 =head2 equals ($type_constraint)
 237
 238 Override the base class behavior so that a dependent type equal both the parent
 239 type and the overall dependent container.  This behavior may change if we can
 240 figure out what a dependent type is (multiply inheritance or a role...)
 241
 242 =cut
 243
 244 around 'equals' => sub {
 245     my ( $equals, $self, $type_or_name ) = @_;
 246
 247     my $other = defined $type_or_name ?
 248       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 249       Moose->throw_error("Can't call $self ->equals without a parameter");
 250
 251     Moose->throw_error("$type_or_name is not a registered Type")
 252      unless $other;
 253
 254     if(my $parent = $other->parent) {
 255         return $self->$equals($other)
 256          || $self->parent->equals($parent);
 257     } else {
 258         return $self->$equals($other);
 259     }
 260 };
 261
 262 =head2 is_subtype_of
 263
 264 Method modifier to make sure we match on subtype for both the dependent type
 265 as well as the type being made dependent
 266
 267 =cut
 268
 269 around 'is_subtype_of' => sub {
 270     my ( $is_subtype_of, $self, $type_or_name ) = @_;
 271
 272     my $other = defined $type_or_name ?
 273       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 274       Moose->throw_error("Can't call $self ->equals without a parameter");
 275
 276     Moose->throw_error("$type_or_name is not a registered Type")
 277      unless $other;
 278
 279     return $self->$is_subtype_of($other)
 280         || $self->parent_type_constraint->is_subtype_of($other);
 281
 282 };
 283
 284 =head2 check
 285
 286 As with 'is_subtype_of', we need to dual dispatch the method request
 287
 288 =cut
 289
 290 around 'check' => sub {
 291     my ($check, $self, @args) = @_;
 292     return (
 293         $self->parent_type_constraint->check(@args) &&
 294         $self->$check(@args)
 295     );
 296 };
 297
 298 =head2 validate
 299
 300 As with 'is_subtype_of', we need to dual dispatch the method request
 301
 302 =cut
 303
 304 around 'validate' => sub {
 305     my ($validate, $self, @args) = @_;
 306     return (
 307         $self->parent_type_constraint->validate(@args) ||
 308         $self->$validate(@args)
 309     );
 310 };
 311
 312 =head2 _compiled_type_constraint
 313
 314 modify this method so that we pass along the constraining value to the constraint
 315 coderef and also throw the correct error message if the constraining value does
 316 not match it's requirement.
 317
 318 =cut
 319
 320 around '_compiled_type_constraint' => sub {
 321     my ($method, $self, @args) = @_;
 322     my $coderef = $self->$method(@args);
 323     my $constraining;
 324     if($self->has_constraining_value) {
 325         $constraining = $self->constraining_value;
 326     }
 327
 328     return sub {
 329         my @local_args = @_;
 330         if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
 331             Moose->throw_error($err);
 332         }
 333         $coderef->(@local_args, $constraining);
 334     };
 335 };
 336
 337 =head2 coerce
 338
 339 More method modification to support dispatch coerce to a parent.
 340
 341 =cut
 342
 343 around 'coerce' => sub {
 344     my ($coerce, $self, @args) = @_;
 345
 346     if($self->has_constraining_value) {
 347         push @args, $self->constraining_value;
 348         ##Checking the type_coercion_map is probably evil
 349         if(@{$self->coercion->type_coercion_map}) {
 350             my $coercion = $self->coercion;
 351             warn "coercion map found in $coercion found for $self";
 352             my $coerced = $self->$coerce(@args);
 353             if(defined $coerced) {
 354                 warn "got coerced args of ", $coerced;
 355                 return $coerced;
 356             } else {
 357                 my $parent = $self->parent;
 358                 warn "no coercion for $self, using $parent";
 359                 return $parent->coerce(@args);
 360             }
 361         } else {
 362             my $parent = $self->parent;
 363             #warn "no coercion for $self, using $parent";
 364             return $parent->coerce(@args);
 365         }
 366     }
 367     else {
 368         return $self->$coerce(@args);
 369     }
 370     return;
 371 };
 372
 373 =head2 get_message
 374
 375 Give you a better peek into what's causing the error.
 376
 377 around 'get_message' => sub {
 378     my ($get_message, $self, $value) = @_;
 379     return $self->$get_message($value);
 380 };
 381
 382 =head1 SEE ALSO
 383
 384 The following modules or resources may be of interest.
 385
 386 L<Moose>, L<Moose::Meta::TypeConstraint>
 387
 388 =head1 AUTHOR
 389
 390 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 391
 392 =head1 COPYRIGHT & LICENSE
 393
 394 This program is free software; you can redistribute it and/or modify
 395 it under the same terms as Perl itself.
 396
 397 =cut
 398
 399 1;
 400 ##__PACKAGE__->meta->make_immutable(inline_constructor => 0);
 401