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