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