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