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 new
  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.
  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 parameterized constraint
  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                     message => $self->message,
 199                 );
 200
 201                 ## TODO This is probably going to have to go away (too many things added to the registry)
 202                 ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 203                 return $type_constraint;
 204             }
 205         }
 206     }
 207 }
 208
 209 =head2 _generate_subtype_name
 210
 211 Returns a name for the parameterizable type that should be unique
 212
 213 =cut
 214
 215 sub _generate_subtype_name {
 216     my ($self, $parent_tc, $constraining_tc) = @_;
 217     return sprintf(
 218         $self."[%s, %s]",
 219         $parent_tc, $constraining_tc,
 220     );
 221 }
 222
 223 =head2 create_child_type
 224
 225 modifier to make sure we get the constraint_generator
 226
 227 =cut
 228
 229 around 'create_child_type' => sub {
 230     my ($create_child_type, $self, %opts) = @_;
 231     if($self->has_constraining_value) {
 232         $opts{constraining_value} = $self->constraining_value;
 233     }
 234     return $self->$create_child_type(
 235         %opts,
 236         parent=> $self,
 237         parent_type_constraint=>$self->parent_type_constraint,
 238         constraining_value_type_constraint => $self->constraining_value_type_constraint,
 239     );
 240 };
 241
 242 =head2 equals ($type_constraint)
 243
 244 Override the base class behavior so that a parameterizable type equal both the parent
 245 type and the overall parameterizable container.  This behavior may change if we can
 246 figure out what a parameterizable type is (multiply inheritance or a role...)
 247
 248 =cut
 249
 250 around 'equals' => sub {
 251     my ( $equals, $self, $type_or_name ) = @_;
 252
 253     my $other = defined $type_or_name ?
 254       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 255       Moose->throw_error("Can't call $self ->equals without a parameter");
 256
 257     Moose->throw_error("$type_or_name is not a registered Type")
 258      unless $other;
 259
 260     if(my $parent = $other->parent) {
 261         return $self->$equals($other)
 262          || $self->parent->equals($parent);
 263     } else {
 264         return $self->$equals($other);
 265     }
 266 };
 267
 268 =head2 is_subtype_of
 269
 270 Method modifier to make sure we match on subtype for both the parameterizable type
 271 as well as the type being made parameterizable
 272
 273 =cut
 274
 275 around 'is_subtype_of' => sub {
 276     my ( $is_subtype_of, $self, $type_or_name ) = @_;
 277
 278     my $other = defined $type_or_name ?
 279       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 280       Moose->throw_error("Can't call $self ->equals without a parameter");
 281
 282     Moose->throw_error("$type_or_name is not a registered Type")
 283      unless $other;
 284
 285     return $self->$is_subtype_of($other)
 286         || $self->parent_type_constraint->is_subtype_of($other);
 287
 288 };
 289
 290 =head2 check
 291
 292 As with 'is_subtype_of', we need to dual dispatch the method request
 293
 294 =cut
 295
 296 around 'check' => sub {
 297     my ($check, $self, @args) = @_;
 298     return (
 299         $self->parent_type_constraint->check(@args) &&
 300         $self->$check(@args)
 301     );
 302 };
 303
 304 =head2 validate
 305
 306 As with 'is_subtype_of', we need to dual dispatch the method request
 307
 308 =cut
 309
 310 around 'validate' => sub {
 311     my ($validate, $self, @args) = @_;
 312     return (
 313         $self->parent_type_constraint->validate(@args) ||
 314         $self->$validate(@args)
 315     );
 316 };
 317
 318 =head2 _compiled_type_constraint
 319
 320 modify this method so that we pass along the constraining value to the constraint
 321 coderef and also throw the correct error message if the constraining value does
 322 not match it's requirement.
 323
 324 around 'compile_type_constraint' => sub {
 325     my ($compile_type_constraint, $self, @args) = @_;
 326
 327     if($self->has_type_constraints) {
 328         my $type_constraints = $self->type_constraints;
 329         my $constraint = $self->generate_constraint_for($type_constraints);
 330         $self->_set_constraint($constraint);
 331     }
 332
 333     return $self->$compile_type_constraint(@args);
 334 };
 335
 336
 337 =cut
 338
 339 around '_compiled_type_constraint' => sub {
 340     my ($method, $self, @args) = @_;
 341     my $coderef = $self->$method(@args);
 342     my $constraining;
 343     if($self->has_constraining_value) {
 344         $constraining = $self->constraining_value;
 345     }
 346
 347     return sub {
 348         my @local_args = @_;
 349         if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
 350             Moose->throw_error($err);
 351         }
 352         $coderef->(@local_args, $constraining);
 353     };
 354 };
 355
 356 =head2 coerce
 357
 358 More method modification to support dispatch coerce to a parent.
 359
 360 =cut
 361
 362 around 'coerce' => sub {
 363     my ($coerce, $self, @args) = @_;
 364     if($self->has_constraining_value) {
 365         push @args, $self->constraining_value;
 366     }
 367     if(@{$self->coercion->type_coercion_map}) {
 368         my $coercion = $self->coercion;
 369         my $coerced = $coercion->coerce(@args);
 370         if(defined $coerced) {
 371             return $coerced;
 372         } else {
 373             my $parent = $self->parent;
 374             return $parent->coerce(@args);
 375         }
 376     } else {
 377         my $parent = $self->parent;
 378         return $parent->coerce(@args);
 379     }
 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 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 400