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