lib/MooseX/Meta/TypeConstraint/Dependent.pm

   1 package ## Hide from PAUSE
   2  MooseX::Meta::TypeConstraint::Dependent;
   3
   4 use Moose;
   5 use Moose::Util::TypeConstraints ();
   6 use MooseX::Meta::TypeCoercion::Dependent;
   7 extends 'Moose::Meta::TypeConstraint';
   8
   9 =head1 NAME
  10
  11 MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
  12
  13 =head1 DESCRIPTION
  14
  15 see L<MooseX::Types::Dependent> for examples and details of how to use dependent
  16 types.  This class is a subclass of L<Moose::Meta::TypeConstraint> which
  17 provides the gut functionality to enable dependent type constraints.
  18
  19 =head1 ATTRIBUTES
  20
  21 This class defines the following attributes.
  22
  23 =head2 dependent_type_constraint
  24
  25 The type constraint whose validity is being made dependent on a value that is a
  26 L</constraining_type_constraint>
  27
  28 =cut
  29
  30 has 'dependent_type_constraint' => (
  31     is=>'ro',
  32     isa=>'Object',
  33     predicate=>'has_dependent_type_constraint',
  34     required=>1,
  35     handles=>{
  36         check_dependent=>'check',
  37     },
  38 );
  39
  40 =head2 constraining_type_constraint
  41
  42 This is a type constraint which defines what kind of value is allowed to be the
  43 constraining value of the depending type.
  44
  45 =cut
  46
  47 has 'constraining_type_constraint' => (
  48     is=>'ro',
  49     isa=>'Object',
  50     predicate=>'has_constraining_type_constraint',
  51     required=>1,
  52     handles=>{
  53         check_constraining=>'check',
  54     },
  55 );
  56
  57 =head2 comparison_callback
  58
  59 This is a callback which returns a boolean value.  It get's passed the value
  60 L</constraining_type_constraint> validates as well as the check value.
  61
  62 This callback is executed in addition to anything you put into a 'where' clause.
  63 However, the 'where' clause only get's the check value.
  64
  65 Exercise some sanity, this should be limited to actual comparision operations,
  66 not as a sneaky way to mess with the constraining value.
  67
  68 =cut
  69
  70 has 'comparison_callback' => (
  71     is=>'ro',
  72     isa=>'CodeRef',
  73     predicate=>'has_comparison_callback',
  74     required=>1,
  75 );
  76
  77 =head2 constraint_generator
  78
  79 A subref or closure that contains the way we validate incoming values against
  80 a set of type constraints.
  81
  82 =cut
  83
  84 has 'constraint_generator' => (
  85     is=>'ro',
  86     isa=>'CodeRef',
  87     predicate=>'has_constraint_generator',
  88     required=>1,
  89 );
  90
  91 =head1 METHODS
  92
  93 This class defines the following methods.
  94
  95 =head2 new
  96
  97 Initialization stuff.
  98
  99 =cut
 100
 101 around 'new' => sub {
 102     my ($new, $class, @args)  = @_;
 103     my $self = $class->$new(@args);
 104     $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new(
 105         type_constraint => $self,
 106     ));
 107     return $self;
 108 };
 109
 110 =head2 check($check_value, $constraining_value)
 111
 112 Make sure when properly dispatch all the right values to the right spots
 113
 114 =cut
 115
 116 around 'check' => sub {
 117     my ($check, $self, @args) = @_;
 118     return $self->$check(@args);
 119 };
 120
 121 =head2 generate_constraint_for ($type_constraints)
 122
 123 Given some type constraints, use them to generate validation rules for an ref
 124 of values (to be passed at check time)
 125
 126 =cut
 127
 128 sub generate_constraint_for {
 129     my ($self, $callback, $constraining) = @_;
 130     return sub {
 131         my ($dependent_pair) = @_;
 132         my ($check_value, $constraining_value) = @$dependent_pair;
 133
 134         ## First need to test the bits
 135         unless($self->check_dependent($check_value)) {
 136             return;
 137         }
 138
 139         unless($self->check_constraining($constraining_value)) {
 140             return;
 141         }
 142
 143         my $constraint_generator = $self->constraint_generator;
 144         return $constraint_generator->(
 145             $callback,
 146             $check_value,
 147             $constraining_value,
 148         );
 149     };
 150 }
 151
 152 =head2 parameterize ($dependent, $callback, $constraining)
 153
 154 Given a ref of type constraints, create a structured type.
 155
 156 =cut
 157
 158 sub parameterize {
 159     my ($self, $dependent, $callback, $constraining) = @_;
 160     my $class = ref $self;
 161     my $name = $self->_generate_subtype_name($dependent,  $callback, $constraining);
 162     my $constraint_generator = $self->__infer_constraint_generator;
 163
 164     return $class->new(
 165         name => $name,
 166         parent => $self,
 167         dependent_type_constraint=>$dependent,
 168         comparison_callback=>$callback,
 169         constraint_generator => $constraint_generator,
 170         constraining_type_constraint => $constraining,
 171     );
 172 }
 173
 174 =head2 _generate_subtype_name
 175
 176 Returns a name for the dependent type that should be unique
 177
 178 =cut
 179
 180 sub _generate_subtype_name {
 181     my ($self, $dependent, $callback, $constraining) = @_;
 182     return sprintf(
 183         "%s_depends_on_%s_via_%s",
 184         $dependent, $constraining, $callback
 185     );
 186 }
 187
 188 =head2 __infer_constraint_generator
 189
 190 This returns a CODEREF which generates a suitable constraint generator.  Not
 191 user servicable, you'll never call this directly.
 192
 193     TBD, this is definitely going to need some work.
 194
 195 =cut
 196
 197 sub __infer_constraint_generator {
 198     my ($self) = @_;
 199     if($self->has_constraint_generator) {
 200         return $self->constraint_generator;
 201     } else {
 202         return sub {
 203             ## I'm not sure about this stuff but everything seems to work
 204             my $tc = shift @_;
 205             my $merged_tc = [
 206                 @$tc,
 207                 $self->comparison_callback,
 208                 $self->constraining_type_constraint,
 209             ];
 210
 211             $self->constraint->($merged_tc, @_);
 212         };
 213     }
 214 }
 215
 216 =head2 compile_type_constraint
 217
 218 hook into compile_type_constraint so we can set the correct validation rules.
 219
 220 =cut
 221
 222 around 'compile_type_constraint' => sub {
 223     my ($compile_type_constraint, $self) = @_;
 224
 225     if($self->has_comparison_callback &&
 226         $self->has_constraining_type_constraint) {
 227         my $generated_constraint = $self->generate_constraint_for(
 228             $self->comparison_callback,
 229              $self->constraining_type_constraint,
 230         );
 231         $self->_set_constraint($generated_constraint);
 232     }
 233
 234     return $self->$compile_type_constraint;
 235 };
 236
 237 =head2 create_child_type
 238
 239 modifier to make sure we get the constraint_generator
 240
 241 around 'create_child_type' => sub {
 242     my ($create_child_type, $self, %opts) = @_;
 243     return $self->$create_child_type(
 244         %opts,
 245         constraint_generator => $self->__infer_constraint_generator,
 246     );
 247 };
 248
 249 =head2 is_a_type_of
 250
 251 =head2 is_subtype_of
 252
 253 =head2 equals
 254
 255 Override the base class behavior.
 256
 257     TBD
 258
 259 sub equals {
 260     my ( $self, $type_or_name ) = @_;
 261     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 262
 263     return unless $other->isa(__PACKAGE__);
 264
 265     return (
 266         $self->type_constraints_equals($other)
 267             and
 268         $self->parent->equals( $other->parent )
 269     );
 270 }
 271
 272 =head2 type_constraints_equals
 273
 274 Checks to see if the internal type contraints are equal.
 275
 276     TBD
 277
 278 sub type_constraints_equals {
 279     my ($self, $other) = @_;
 280     my @self_type_constraints = @{$self->type_constraints||[]};
 281     my @other_type_constraints = @{$other->type_constraints||[]};
 282
 283     ## Incoming ay be either arrayref or hashref, need top compare both
 284     while(@self_type_constraints) {
 285         my $self_type_constraint = shift @self_type_constraints;
 286         my $other_type_constraint = shift @other_type_constraints
 287          || return; ## $other needs the same number of children.
 288
 289         if( ref $self_type_constraint) {
 290             $self_type_constraint->equals($other_type_constraint)
 291              || return; ## type constraints obviously need top be equal
 292         } else {
 293             $self_type_constraint eq $other_type_constraint
 294              || return; ## strings should be equal
 295         }
 296
 297     }
 298
 299     return 1; ##If we get this far, everything is good.
 300 }
 301
 302 =head2 get_message
 303
 304 Give you a better peek into what's causing the error.  For now we stringify the
 305 incoming deep value with L<Devel::PartialDump> and pass that on to either your
 306 custom error message or the default one.  In the future we'll try to provide a
 307 more complete stack trace of the actual offending elements
 308
 309     TBD
 310
 311 around 'get_message' => sub {
 312     my ($get_message, $self, $value) = @_;
 313     my $new_value = Devel::PartialDump::dump($value);
 314     return $self->$get_message($new_value);
 315 };
 316
 317 =head1 SEE ALSO
 318
 319 The following modules or resources may be of interest.
 320
 321 L<Moose>, L<Moose::Meta::TypeConstraint>
 322
 323 =head1 AUTHOR
 324
 325 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 326
 327 =head1 COPYRIGHT & LICENSE
 328
 329 This program is free software; you can redistribute it and/or modify
 330 it under the same terms as Perl itself.
 331
 332 =cut
 333
 334 __PACKAGE__->meta->make_immutable;