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 This should return a Bool, suitable for ->check (That is true for valid, false
  67 for fail).
  68
  69 =cut
  70
  71 has 'comparison_callback' => (
  72     is=>'ro',
  73     isa=>'CodeRef',
  74     predicate=>'has_comparison_callback',
  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 generate_constraint_for ($type_constraints)
 111
 112 Given some type constraints, use them to generate validation rules for an ref
 113 of values (to be passed at check time)
 114
 115 =cut
 116
 117 sub generate_constraint_for {
 118     my ($self, $callback) = @_;
 119     return sub {
 120         my ($dependent_pair) = @_;
 121         my ($dependent, $constraining) = @$dependent_pair;
 122
 123         ## First need to test the bits
 124         unless($self->check_dependent($dependent)) {
 125             return;
 126         }
 127
 128         unless($self->check_constraining($constraining)) {
 129             return;
 130         }
 131
 132         my $constraint_generator = $self->constraint_generator;
 133         return $constraint_generator->(
 134             $dependent,
 135             $callback,
 136             $constraining,
 137         );
 138     };
 139 }
 140
 141 =head2 parameterize ($dependent, $callback, $constraining)
 142
 143 Given a ref of type constraints, create a structured type.
 144
 145 =cut
 146
 147 sub parameterize {
 148     my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
 149     my $class = ref $self;
 150     my $name = $self->_generate_subtype_name($dependent_tc,  $callback, $constraining_tc);
 151     my $constraint_generator = $self->__infer_constraint_generator;
 152
 153     return $class->new(
 154         name => $name,
 155         parent => $self,
 156         dependent_type_constraint=>$dependent_tc,
 157         comparison_callback=>$callback,
 158         constraint_generator => $constraint_generator,
 159         constraining_type_constraint => $constraining_tc,
 160     );
 161 }
 162
 163 =head2 _generate_subtype_name
 164
 165 Returns a name for the dependent type that should be unique
 166
 167 =cut
 168
 169 sub _generate_subtype_name {
 170     my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
 171     return sprintf(
 172         "%s_depends_on_%s_via_%s",
 173         $dependent_tc, $constraining_tc, $callback,
 174     );
 175 }
 176
 177 =head2 __infer_constraint_generator
 178
 179 This returns a CODEREF which generates a suitable constraint generator.  Not
 180 user servicable, you'll never call this directly.
 181
 182     TBD, this is definitely going to need some work.
 183
 184 =cut
 185
 186 sub __infer_constraint_generator {
 187     my ($self) = @_;
 188     if($self->has_constraint_generator) {
 189         return $self->constraint_generator;
 190     } else {
 191         warn "I'm doing the questioning infer generator thing";
 192         return sub {
 193             ## I'm not sure about this stuff but everything seems to work
 194             my $tc = shift @_;
 195             my $merged_tc = [
 196                 @$tc,
 197                 $self->comparison_callback,
 198                 $self->constraining_type_constraint,
 199             ];
 200
 201             $self->constraint->($merged_tc, @_);
 202         };
 203     }
 204 }
 205
 206 =head2 compile_type_constraint
 207
 208 hook into compile_type_constraint so we can set the correct validation rules.
 209
 210 =cut
 211
 212 around 'compile_type_constraint' => sub {
 213     my ($compile_type_constraint, $self) = @_;
 214
 215     if($self->has_comparison_callback &&
 216         $self->has_constraining_type_constraint) {
 217         my $generated_constraint = $self->generate_constraint_for(
 218             $self->comparison_callback,
 219         );
 220         $self->_set_constraint($generated_constraint);
 221     }
 222
 223     return $self->$compile_type_constraint;
 224 };
 225
 226 =head2 create_child_type
 227
 228 modifier to make sure we get the constraint_generator
 229
 230 =cut
 231
 232 around 'create_child_type' => sub {
 233     my ($create_child_type, $self, %opts) = @_;
 234     return $self->$create_child_type(
 235         %opts,
 236         constraint_generator => $self->__infer_constraint_generator,
 237     );
 238 };
 239
 240 =head2 is_a_type_of
 241
 242 =head2 is_subtype_of
 243
 244 =head2 equals
 245
 246 Override the base class behavior.
 247
 248     TBD
 249
 250 sub equals {
 251     my ( $self, $type_or_name ) = @_;
 252     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 253
 254     return unless $other->isa(__PACKAGE__);
 255
 256     return (
 257         $self->type_constraints_equals($other)
 258             and
 259         $self->parent->equals( $other->parent )
 260     );
 261 }
 262
 263 =head2 type_constraints_equals
 264
 265 Checks to see if the internal type contraints are equal.
 266
 267     TBD
 268
 269 sub type_constraints_equals {
 270     my ($self, $other) = @_;
 271     my @self_type_constraints = @{$self->type_constraints||[]};
 272     my @other_type_constraints = @{$other->type_constraints||[]};
 273
 274     ## Incoming ay be either arrayref or hashref, need top compare both
 275     while(@self_type_constraints) {
 276         my $self_type_constraint = shift @self_type_constraints;
 277         my $other_type_constraint = shift @other_type_constraints
 278          || return; ## $other needs the same number of children.
 279
 280         if( ref $self_type_constraint) {
 281             $self_type_constraint->equals($other_type_constraint)
 282              || return; ## type constraints obviously need top be equal
 283         } else {
 284             $self_type_constraint eq $other_type_constraint
 285              || return; ## strings should be equal
 286         }
 287
 288     }
 289
 290     return 1; ##If we get this far, everything is good.
 291 }
 292
 293 =head2 get_message
 294
 295 Give you a better peek into what's causing the error.  For now we stringify the
 296 incoming deep value with L<Devel::PartialDump> and pass that on to either your
 297 custom error message or the default one.  In the future we'll try to provide a
 298 more complete stack trace of the actual offending elements
 299
 300     TBD
 301
 302 around 'get_message' => sub {
 303     my ($get_message, $self, $value) = @_;
 304     my $new_value = Devel::PartialDump::dump($value);
 305     return $self->$get_message($new_value);
 306 };
 307
 308 =head1 SEE ALSO
 309
 310 The following modules or resources may be of interest.
 311
 312 L<Moose>, L<Moose::Meta::TypeConstraint>
 313
 314 =head1 AUTHOR
 315
 316 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 317
 318 =head1 COPYRIGHT & LICENSE
 319
 320 This program is free software; you can redistribute it and/or modify
 321 it under the same terms as Perl itself.
 322
 323 =cut
 324
 325 __PACKAGE__->meta->make_immutable;