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 Scalar::Util qw(blessed);
   7 use Data::Dump;
   8 use Digest::MD5;
   9
  10 extends 'Moose::Meta::TypeConstraint';
  11
  12 =head1 NAME
  13
  14 MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
  15
  16 =head1 DESCRIPTION
  17
  18 see L<MooseX::Dependent> for examples and details of how to use dependent
  19 types.  This class is a subclass of L<Moose::Meta::TypeConstraint> which
  20 provides the gut functionality to enable dependent type constraints.
  21
  22 =head1 ATTRIBUTES
  23
  24 This class defines the following attributes.
  25
  26 =head2 parent_type_constraint
  27
  28 The type constraint whose validity is being made dependent.
  29
  30 =cut
  31
  32 has 'parent_type_constraint' => (
  33     is=>'ro',
  34     isa=>'Object',
  35     default=> sub {
  36         Moose::Util::TypeConstraints::find_type_constraint("Any");
  37     },
  38     required=>1,
  39 );
  40
  41
  42 =head2 constraining_value_type_constraint
  43
  44 This is a type constraint which defines what kind of value is allowed to be the
  45 constraining value of the dependent type.
  46
  47 =cut
  48
  49 has 'constraining_value_type_constraint' => (
  50     is=>'ro',
  51     isa=>'Object',
  52     default=> sub {
  53         Moose::Util::TypeConstraints::find_type_constraint("Any");
  54     },
  55     required=>1,
  56 );
  57
  58 =head2 constraining_value
  59
  60 This is the actual value that constraints the L</parent_type_constraint>
  61
  62 =cut
  63
  64 has 'constraining_value' => (
  65     is=>'ro',
  66     predicate=>'has_constraining_value',
  67 );
  68
  69 =head1 METHODS
  70
  71 This class defines the following methods.
  72
  73 =head2 parameterize (@args)
  74
  75 Given a ref of type constraints, create a structured type.
  76
  77 =cut
  78
  79 sub parameterize {
  80     my $self = shift @_;
  81     my $class = ref $self;
  82
  83     Moose->throw_error("$self already has a constraining value.") if
  84      $self->has_constraining_value;
  85
  86     if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
  87         my $arg1 = shift @_;
  88
  89         if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) {
  90             my $arg2 = shift @_ || $self->constraining_value_type_constraint;
  91
  92             ## TODO fix this crap!
  93             Moose->throw_error("$arg2 is not a type constraint")
  94              unless $arg2->isa('Moose::Meta::TypeConstraint');
  95
  96             Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name)
  97              unless $arg1->is_a_type_of($self->parent_type_constraint);
  98
  99             Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name)
 100              unless $arg2->is_a_type_of($self->constraining_value_type_constraint);
 101
 102             Moose->throw_error('Too Many Args!  Two are allowed.') if @_;
 103
 104             my $name = $self->_generate_subtype_name($arg1, $arg2);
 105             if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
 106                 return $exists;
 107             } else {
 108                 my $type_constraint = $class->new(
 109                     name => $name,
 110                     parent => $self,
 111                     constraint => $self->constraint,
 112                     parent_type_constraint=>$arg1,
 113                     constraining_value_type_constraint => $arg2,
 114                 );
 115                 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 116                 return $type_constraint;
 117             }
 118         } else {
 119             Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
 120              unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
 121
 122             my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
 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=>$self->parent_type_constraint,
 131                     constraining_value_type_constraint => $arg1,
 132                 );
 133                 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 134                 return $type_constraint;
 135             }
 136         }
 137     } else {
 138         my $args;
 139         ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}]
 140         if(@_) {
 141             if($#_) {
 142                 if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) {
 143                     $args = {@_};
 144                 } else {
 145                     $args = [@_];
 146                 }
 147             } else {
 148                 $args = $_[0];
 149             }
 150
 151         } else {
 152             ## TODO:  Is there a use case for parameterizing null or undef?
 153             Moose->throw_error('Cannot Parameterize null values.');
 154         }
 155
 156         if(my $err = $self->constraining_value_type_constraint->validate($args)) {
 157             Moose->throw_error($err);
 158         } else {
 159
 160             my $sig = $args;
 161             if(ref $sig) {
 162                 $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));
 163             }
 164             my $name = $self->name."[$sig]";
 165             if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
 166                 return $exists;
 167             } else {
 168                 my $type_constraint = $class->new(
 169                     name => $name,
 170                     parent => $self,
 171                     constraint => $self->constraint,
 172                     constraining_value => $args,
 173                     parent_type_constraint=>$self->parent_type_constraint,
 174                     constraining_value_type_constraint => $self->constraining_value_type_constraint,
 175                 );
 176                 Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
 177                 return $type_constraint;
 178             }
 179         }
 180     }
 181 }
 182
 183 =head2 _generate_subtype_name
 184
 185 Returns a name for the dependent type that should be unique
 186
 187 =cut
 188
 189 sub _generate_subtype_name {
 190     my ($self, $parent_tc, $constraining_tc) = @_;
 191     return sprintf(
 192         $self."[%s, %s]",
 193         $parent_tc, $constraining_tc,
 194     );
 195 }
 196
 197 =head2 create_child_type
 198
 199 modifier to make sure we get the constraint_generator
 200
 201 =cut
 202
 203 around 'create_child_type' => sub {
 204     my ($create_child_type, $self, %opts) = @_;
 205     if($self->has_constraining_value) {
 206         $opts{constraining_value} = $self->constraining_value;
 207     }
 208     return $self->$create_child_type(
 209         %opts,
 210         parent=> $self,
 211         parent_type_constraint=>$self->parent_type_constraint,
 212         constraining_value_type_constraint => $self->constraining_value_type_constraint,
 213     );
 214 };
 215
 216 =head2 equals ($type_constraint)
 217
 218 Override the base class behavior so that a dependent type equal both the parent
 219 type and the overall dependent container.  This behavior may change if we can
 220 figure out what a dependent type is (multiply inheritance or a role...)
 221
 222 =cut
 223
 224 around 'equals' => sub {
 225     my ( $equals, $self, $type_or_name ) = @_;
 226
 227     my $other = defined $type_or_name ?
 228       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 229       Moose->throw_error("Can't call $self ->equals without a parameter");
 230
 231     Moose->throw_error("$type_or_name is not a registered Type")
 232      unless $other;
 233
 234     if(my $parent = $other->parent) {
 235         return $self->$equals($other)
 236          || $self->parent->equals($parent);
 237     } else {
 238         return $self->$equals($other);
 239     }
 240 };
 241
 242 around 'is_subtype_of' => sub {
 243     my ( $is_subtype_of, $self, $type_or_name ) = @_;
 244
 245     my $other = defined $type_or_name ?
 246       Moose::Util::TypeConstraints::find_type_constraint($type_or_name) :
 247       Moose->throw_error("Can't call $self ->equals without a parameter");
 248
 249     Moose->throw_error("$type_or_name is not a registered Type")
 250      unless $other;
 251
 252     return $self->$is_subtype_of($other)
 253         || $self->parent_type_constraint->is_subtype_of($other);
 254
 255 };
 256
 257 sub is_a_type_of {
 258     my ($self, @args) = @_;
 259     return ($self->equals(@args) ||
 260       $self->is_subtype_of(@args));
 261 }
 262
 263 around 'check' => sub {
 264     my ($check, $self, @args) = @_;
 265     return (
 266         $self->parent_type_constraint->check(@args) &&
 267         $self->$check(@args)
 268     );
 269 };
 270
 271 around 'validate' => sub {
 272     my ($validate, $self, @args) = @_;
 273     return (
 274         $self->parent_type_constraint->validate(@args) ||
 275         $self->$validate(@args)
 276     );
 277 };
 278
 279 around '_compiled_type_constraint' => sub {
 280     my ($method, $self, @args) = @_;
 281     my $coderef = $self->$method(@args);
 282     my $constraining;
 283     if($self->has_constraining_value) {
 284         $constraining = $self->constraining_value;
 285     }
 286
 287     return sub {
 288         my @local_args = @_;
 289         if(my $err = $self->constraining_value_type_constraint->validate($constraining)) {
 290             Moose->throw_error($err);
 291         }
 292         $coderef->(@local_args, $constraining);
 293     };
 294 };
 295
 296 around 'coerce' => sub {
 297     my ($coerce, $self, @args) = @_;
 298     if($self->coercion) {
 299         if(my $value = $self->$coerce(@args)) {
 300             return $value;
 301         }
 302     }
 303     return $self->parent->coerce(@args);
 304 };
 305
 306 =head2 get_message
 307
 308 Give you a better peek into what's causing the error.
 309
 310 around 'get_message' => sub {
 311     my ($get_message, $self, $value) = @_;
 312     return $self->$get_message($value);
 313 };
 314
 315 =head1 SEE ALSO
 316
 317 The following modules or resources may be of interest.
 318
 319 L<Moose>, L<Moose::Meta::TypeConstraint>
 320
 321 =head1 AUTHOR
 322
 323 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 324
 325 =head1 COPYRIGHT & LICENSE
 326
 327 This program is free software; you can redistribute it and/or modify
 328 it under the same terms as Perl itself.
 329
 330 =cut
 331
 332 __PACKAGE__->meta->make_immutable(inline_constructor => 0);
 333