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 use Devel::PartialDump;
   8 extends 'Moose::Meta::TypeConstraint';
   9
  10 =head1 NAME
  11
  12 MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints.
  13
  14 =head1 DESCRIPTION
  15
  16 see L<MooseX::Types::Dependent> for examples and details of how to use dependent
  17 types.  This class is a subclass of L<Moose::Meta::TypeConstraint> which
  18 provides the gut functionality to enable dependent type constraints.
  19
  20 =head1 ATTRIBUTES
  21
  22 This class defines the following attributes.
  23
  24 =head2 dependent_type_constraint
  25
  26 The type constraint whose validity is being made dependent on a value that is a
  27 L</constraining_type_constraint>
  28
  29 =cut
  30
  31 has 'dependent_type_constraint' => (
  32     is=>'ro',
  33     isa=>'Object',
  34     predicate=>'has_dependent_type_constraint',
  35     handles=>{
  36         check_dependent=>'check',
  37         get_message_dependent=>'get_message',
  38     },
  39 );
  40
  41 =head2 constraining_type_constraint
  42
  43 This is a type constraint which defines what kind of value is allowed to be the
  44 constraining value of the depending type.
  45
  46 =cut
  47
  48 has 'constraining_type_constraint' => (
  49     is=>'ro',
  50     isa=>'Object',
  51     predicate=>'has_constraining_type_constraint',
  52     handles=>{
  53         check_constraining=>'check',
  54         get_message_constraining=>'get_message',
  55     },
  56 );
  57
  58 =head2 comparison_callback
  59
  60 This is a callback which returns a boolean value.  It get's passed the value
  61 L</constraining_type_constraint> validates as well as the check value.
  62
  63 This callback is executed in addition to anything you put into a 'where' clause.
  64 However, the 'where' clause only get's the check value.
  65
  66 Exercise some sanity, this should be limited to actual comparision operations,
  67 not as a sneaky way to mess with the constraining value.
  68
  69 This should return a Bool, suitable for ->check (That is true for valid, false
  70 for fail).
  71
  72 =cut
  73
  74 has 'comparison_callback' => (
  75     is=>'ro',
  76     isa=>'CodeRef',
  77     predicate=>'has_comparison_callback',
  78 );
  79
  80 =head2 constraint_generator
  81
  82 A subref or closure that contains the way we validate incoming values against
  83 a set of type constraints.
  84
  85 =cut
  86
  87 has 'constraint_generator' => (
  88     is=>'ro',
  89     isa=>'CodeRef',
  90     predicate=>'has_constraint_generator',
  91     required=>1,
  92 );
  93
  94 =head1 METHODS
  95
  96 This class defines the following methods.
  97
  98 =head2 new
  99
 100 Initialization stuff.
 101
 102 =cut
 103
 104 around 'new' => sub {
 105     my ($new, $class, @args)  = @_;
 106     my $self = $class->$new(@args);
 107     $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new(
 108         type_constraint => $self,
 109     ));
 110     return $self;
 111 };
 112
 113 =head2 validate
 114
 115 We intercept validate in order to custom process the message.
 116
 117 =cut
 118
 119 override 'validate' => sub {
 120     my ($self, @args) = @_;
 121     my $compiled_type_constraint = $self->_compiled_type_constraint;
 122     my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message';
 123     my $result = $compiled_type_constraint->(@args, $message);
 124
 125     if($result) {
 126         return $result;
 127     } else {
 128         my $args = Devel::PartialDump::dump(@args);
 129         if(my $message = $message->{message}) {
 130             return $self->get_message("$args, Internal Validation Error is: $message");
 131         } else {
 132             return $self->get_message($args);
 133         }
 134     }
 135 };
 136
 137 =head2 generate_constraint_for ($type_constraints)
 138
 139 Given some type constraints, use them to generate validation rules for an ref
 140 of values (to be passed at check time)
 141
 142 =cut
 143
 144 sub generate_constraint_for {
 145     my ($self, $callback) = @_;
 146     return sub {
 147         my $dependent_pair = shift @_;
 148         my ($dependent, $constraining) = @$dependent_pair;
 149
 150         ## First need to test the bits
 151         unless($self->check_dependent($dependent)) {
 152             $_[0]->{message} = $self->get_message_dependent($dependent)
 153              if $_[0];
 154             return;
 155         }
 156
 157         unless($self->check_constraining($constraining)) {
 158             $_[0]->{message} = $self->get_message_constraining($constraining)
 159              if $_[0];
 160             return;
 161         }
 162
 163         my $constraint_generator = $self->constraint_generator;
 164         return $constraint_generator->(
 165             $dependent,
 166             $callback,
 167             $constraining,
 168         );
 169     };
 170 }
 171
 172 =head2 parameterize ($dependent, $callback, $constraining)
 173
 174 Given a ref of type constraints, create a structured type.
 175
 176 =cut
 177
 178 sub parameterize {
 179     my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
 180     my $class = ref $self;
 181     my $name = $self->_generate_subtype_name($dependent_tc,  $callback, $constraining_tc);
 182     my $constraint_generator = $self->__infer_constraint_generator;
 183
 184     return $class->new(
 185         name => $name,
 186         parent => $self,
 187         dependent_type_constraint=>$dependent_tc,
 188         comparison_callback=>$callback,
 189         constraint_generator => $constraint_generator,
 190         constraining_type_constraint => $constraining_tc,
 191     );
 192 }
 193
 194 =head2 _generate_subtype_name
 195
 196 Returns a name for the dependent type that should be unique
 197
 198 =cut
 199
 200 sub _generate_subtype_name {
 201     my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
 202     return sprintf(
 203         "%s_depends_on_%s_via_%s",
 204         $dependent_tc, $constraining_tc, $callback,
 205     );
 206 }
 207
 208 =head2 __infer_constraint_generator
 209
 210 This returns a CODEREF which generates a suitable constraint generator.  Not
 211 user servicable, you'll never call this directly.
 212
 213     TBD, this is definitely going to need some work.  Cargo culted from some
 214     code I saw in Moose::Meta::TypeConstraint::Parameterized or similar.  I
 215     Don't think I need this, since Dependent types require parameters, so
 216     will always have a constrain generator.
 217
 218 =cut
 219
 220 sub __infer_constraint_generator {
 221     my ($self) = @_;
 222     if($self->has_constraint_generator) {
 223         return $self->constraint_generator;
 224     } else {
 225         warn "I'm doing the questionable infer generator thing";
 226         return sub {
 227             ## I'm not sure about this stuff but everything seems to work
 228             my $tc = shift @_;
 229             my $merged_tc = [
 230                 @$tc,
 231                 $self->comparison_callback,
 232                 $self->constraining_type_constraint,
 233             ];
 234
 235             $self->constraint->($merged_tc, @_);
 236         };
 237     }
 238 }
 239
 240 =head2 compile_type_constraint
 241
 242 hook into compile_type_constraint so we can set the correct validation rules.
 243
 244 =cut
 245
 246 around 'compile_type_constraint' => sub {
 247     my ($compile_type_constraint, $self) = @_;
 248
 249     if($self->has_comparison_callback &&
 250         $self->has_constraining_type_constraint) {
 251         my $generated_constraint = $self->generate_constraint_for(
 252             $self->comparison_callback,
 253         );
 254         $self->_set_constraint($generated_constraint);
 255     }
 256
 257     return $self->$compile_type_constraint;
 258 };
 259
 260 =head2 create_child_type
 261
 262 modifier to make sure we get the constraint_generator
 263
 264 =cut
 265
 266 around 'create_child_type' => sub {
 267     my ($create_child_type, $self, %opts) = @_;
 268     return $self->$create_child_type(
 269         %opts,
 270         constraint_generator => $self->__infer_constraint_generator,
 271     );
 272 };
 273
 274 =head2 equals
 275
 276 Override the base class behavior.
 277
 278 =cut
 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 (
 285         $other->isa(__PACKAGE__)
 286             and
 287         $self->dependent_type_constraint->equals($other)
 288             and
 289         $self->constraining_type_constraint->equals($other)
 290             and
 291         $self->parent->equals($other->parent)
 292     );
 293 }
 294
 295 =head2 get_message
 296
 297 Give you a better peek into what's causing the error.
 298
 299 =cut
 300
 301 around 'get_message' => sub {
 302     my ($get_message, $self, $value) = @_;
 303     return $self->$get_message($value);
 304 };
 305
 306 =head1 SEE ALSO
 307
 308 The following modules or resources may be of interest.
 309
 310 L<Moose>, L<Moose::Meta::TypeConstraint>
 311
 312 =head1 AUTHOR
 313
 314 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 315
 316 =head1 COPYRIGHT & LICENSE
 317
 318 This program is free software; you can redistribute it and/or modify
 319 it under the same terms as Perl itself.
 320
 321 =cut
 322
 323 __PACKAGE__->meta->make_immutable;