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