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 =cut
 325
 326 around '_compiled_type_constraint' => sub {
 327     my ($method, $self, @args) = @_;
 328     my $coderef = $self->$method(@args);
 329     my $constraining;
 330     if($self->has_constraining_value) {
 331         $constraining = $self->constraining_value;
 332     }
 333
 334     return sub {
 335         my @local_args = @_;
 336         if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
 337             Moose->throw_error($err);
 338         }
 339         $coderef->(@local_args, $constraining);
 340     };
 341 };
 342
 343 =head2 coerce
 344
 345 More method modification to support dispatch coerce to a parent.
 346
 347 =cut
 348
 349 around 'coerce' => sub {
 350     my ($coerce, $self, @args) = @_;
 351
 352     if($self->has_constraining_value) {
 353         push @args, $self->constraining_value;
 354         if(@{$self->coercion->type_coercion_map}) {
 355             my $coercion = $self->coercion;
 356             my $coerced = $self->$coerce(@args);
 357             if(defined $coerced) {
 358                 return $coerced;
 359             } else {
 360                 my $parent = $self->parent;
 361                 return $parent->coerce(@args);
 362             }
 363         } else {
 364             my $parent = $self->parent;
 365             return $parent->coerce(@args);
 366         }
 367     }
 368     else {
 369         return $self->$coerce(@args);
 370     }
 371     return;
 372 };
 373
 374 =head2 get_message
 375
 376 Give you a better peek into what's causing the error.
 377
 378 around 'get_message' => sub {
 379     my ($get_message, $self, $value) = @_;
 380     return $self->$get_message($value);
 381 };
 382
 383 =head1 SEE ALSO
 384
 385 The following modules or resources may be of interest.
 386
 387 L<Moose>, L<Moose::Meta::TypeConstraint>
 388
 389 =head1 AUTHOR
 390
 391 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 392
 393 =head1 COPYRIGHT & LICENSE
 394
 395 This program is free software; you can redistribute it and/or modify
 396 it under the same terms as Perl itself.
 397
 398 =cut
 399
 400 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 401