lib/MooseX/Meta/TypeConstraint/Parameterizable.pm

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