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