lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm

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