lib/MooseX/Meta/TypeConstraint/Structured.pm

   1 package ## Hide from PAUSE
   2  MooseX::Meta::TypeConstraint::Structured;
   3
   4 use Moose;
   5 use Devel::PartialDump;
   6 use Moose::Util::TypeConstraints ();
   7 use MooseX::Meta::TypeCoercion::Structured;
   8 extends 'Moose::Meta::TypeConstraint';
   9
  10 =head1 NAME
  11
  12 MooseX::Meta::TypeConstraint::Structured - Structured type constraints.
  13
  14 =head1 DESCRIPTION
  15
  16 A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
  17 such a way as that they are all applied to an incoming list of arguments.  The
  18 idea here is that a Type Constraint could be something like, "An Int followed by
  19 an Int and then a Str" and that this could be done so with a declaration like:
  20
  21     Tuple[Int,Int,Str]; ## Example syntax
  22
  23 So a structure is a list of Type constraints (the "Int,Int,Str" in the above
  24 example) which are intended to function together.
  25
  26 =head1 ATTRIBUTES
  27
  28 This class defines the following attributes.
  29
  30 =head2 type_constraints
  31
  32 A list of L<Moose::Meta::TypeConstraint> objects.
  33
  34 =cut
  35
  36 has 'type_constraints' => (
  37     is=>'ro',
  38     isa=>'Ref',
  39     predicate=>'has_type_constraints',
  40 );
  41
  42 =head2 constraint_generator
  43
  44 A subref or closure that contains the way we validate incoming values against
  45 a set of type constraints.
  46
  47 =cut
  48
  49 has 'constraint_generator' => (
  50     is=>'ro',
  51     isa=>'CodeRef',
  52     predicate=>'has_constraint_generator',
  53 );
  54
  55 has coercion => (
  56     is      => 'ro',
  57     isa     => 'Object',
  58     builder => '_build_coercion',
  59 );
  60
  61 =head1 METHODS
  62
  63 This class defines the following methods.
  64
  65 =head2 new
  66
  67 Initialization stuff.
  68
  69 =cut
  70
  71 sub _build_coercion {
  72     my ($self) = @_;
  73     return MooseX::Meta::TypeCoercion::Structured->new(
  74         type_constraint => $self,
  75     );
  76 }
  77
  78 =head2 validate
  79
  80 Messing with validate so that we can support niced error messages.
  81 =cut
  82
  83 override 'validate' => sub {
  84     my ($self, @args) = @_;
  85     my $message = bless {message=>undef}, 'MooseX::Types::Structured::Message';
  86
  87     if ($self->_compiled_type_constraint->(@args, $message)) {
  88         ## Everything is good, no error message to return
  89         return undef;
  90     } else {
  91         ## Whoops, need to figure out the right error message
  92         my $args = Devel::PartialDump::dump(@args);
  93         if(my $message = $message->{message}) {
  94             return $self->get_message("$args, Internal Validation Error is: $message");
  95         } else {
  96             return $self->get_message($args);
  97         }
  98     }
  99 };
 100
 101 =head2 generate_constraint_for ($type_constraints)
 102
 103 Given some type constraints, use them to generate validation rules for an ref
 104 of values (to be passed at check time)
 105
 106 =cut
 107
 108 sub generate_constraint_for {
 109     my ($self, $type_constraints) = @_;
 110     return sub {
 111         my $arg =  shift @_;
 112         my $constraint_generator = $self->constraint_generator;
 113         my $result = $constraint_generator->($type_constraints, $arg, $_[0]);
 114         return $result;
 115     };
 116 }
 117
 118 =head2 parameterize (@type_constraints)
 119
 120 Given a ref of type constraints, create a structured type.
 121
 122 =cut
 123
 124 sub parameterize {
 125
 126     my ($self, @type_constraints) = @_;
 127     my $class = ref $self;
 128     my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
 129     my $constraint_generator = $self->__infer_constraint_generator;
 130
 131     return $class->new(
 132         name => $name,
 133         parent => $self,
 134         type_constraints => \@type_constraints,
 135         constraint_generator => $constraint_generator,
 136     );
 137 }
 138
 139 =head2 __infer_constraint_generator
 140
 141 This returns a CODEREF which generates a suitable constraint generator.  Not
 142 user servicable, you'll never call this directly.
 143
 144 =cut
 145
 146 sub __infer_constraint_generator {
 147     my ($self) = @_;
 148     if($self->has_constraint_generator) {
 149         return $self->constraint_generator;
 150     } else {
 151         return sub {
 152             ## I'm not sure about this stuff but everything seems to work
 153             my $tc = shift @_;
 154             my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
 155             $self->constraint->($merged_tc, @_);
 156         };
 157     }
 158 }
 159
 160 =head2 compile_type_constraint
 161
 162 hook into compile_type_constraint so we can set the correct validation rules.
 163
 164 =cut
 165
 166 around 'compile_type_constraint' => sub {
 167     my ($compile_type_constraint, $self, @args) = @_;
 168
 169     if($self->has_type_constraints) {
 170         my $type_constraints = $self->type_constraints;
 171         my $constraint = $self->generate_constraint_for($type_constraints);
 172         $self->_set_constraint($constraint);
 173     }
 174
 175     return $self->$compile_type_constraint(@args);
 176 };
 177
 178 =head2 create_child_type
 179
 180 modifier to make sure we get the constraint_generator
 181
 182 =cut
 183
 184 around 'create_child_type' => sub {
 185     my ($create_child_type, $self, %opts) = @_;
 186     return $self->$create_child_type(
 187         %opts,
 188         constraint_generator => $self->__infer_constraint_generator,
 189     );
 190 };
 191
 192 =head2 is_a_type_of
 193
 194 =head2 is_subtype_of
 195
 196 =head2 equals
 197
 198 Override the base class behavior.
 199
 200 =cut
 201
 202 sub equals {
 203     my ( $self, $type_or_name ) = @_;
 204     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 205
 206     return unless $other->isa(__PACKAGE__);
 207
 208     return (
 209         $self->parent->equals($other->parent)
 210             and
 211         $self->type_constraints_equals($other)
 212     );
 213 }
 214
 215 sub is_a_type_of {
 216     my ( $self, $type_or_name ) = @_;
 217     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 218
 219     if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) {
 220         if ( $self->parent->is_a_type_of($other->parent) ) {
 221             return $self->_type_constraints_op_all($other, "is_a_type_of");
 222         } elsif ( $self->parent->is_a_type_of($other) ) {
 223             return 1;
 224             # FIXME compare?
 225         } else {
 226             return 0;
 227         }
 228     } else {
 229         return $self->SUPER::is_a_type_of($other);
 230     }
 231 }
 232
 233 sub is_subtype_of {
 234     my ( $self, $type_or_name ) = @_;
 235     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 236     if ( $other->isa(__PACKAGE__) ) {
 237         if ( $other->type_constraints and $self->type_constraints ) {
 238             if ( $self->parent->is_a_type_of($other->parent) ) {
 239                 return (
 240                     $self->_type_constraints_op_all($other, "is_a_type_of")
 241                       and
 242                     $self->_type_constraints_op_any($other, "is_subtype_of")
 243                 );
 244             } elsif ( $self->parent->is_a_type_of($other) ) {
 245                 return 1;
 246                 # FIXME compare?
 247             } else {
 248                 return 0;
 249             }
 250         } else {
 251             if ( $self->type_constraints ) {
 252                 if ( $self->SUPER::is_subtype_of($other) ) {
 253                     return 1;
 254                 } else {
 255                     return;
 256                 }
 257             } else {
 258                 return $self->parent->is_subtype_of($other->parent);
 259             }
 260         }
 261     } else {
 262         return $self->SUPER::is_subtype_of($other);
 263     }
 264 }
 265
 266 =head2 type_constraints_equals
 267
 268 Checks to see if the internal type constraints are equal.
 269
 270 =cut
 271
 272 sub type_constraints_equals {
 273     my ( $self, $other ) = @_;
 274     $self->_type_constraints_op_all($other, "equals");
 275 }
 276
 277 sub _type_constraints_op_all {
 278     my ($self, $other, $op) = @_;
 279
 280     return unless $other->isa(__PACKAGE__);
 281
 282     my @self_type_constraints = @{$self->type_constraints||[]};
 283     my @other_type_constraints = @{$other->type_constraints||[]};
 284
 285     return unless @self_type_constraints == @other_type_constraints;
 286
 287     ## Incoming ay be either arrayref or hashref, need top compare both
 288     while(@self_type_constraints) {
 289         my $self_type_constraint = shift @self_type_constraints;
 290         my $other_type_constraint = shift @other_type_constraints;
 291
 292         $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
 293           for $self_type_constraint, $other_type_constraint;
 294
 295         my $result = $self_type_constraint->$op($other_type_constraint);
 296         return unless $result;
 297     }
 298
 299     return 1; ##If we get this far, everything is good.
 300 }
 301
 302 sub _type_constraints_op_any {
 303     my ($self, $other, $op) = @_;
 304
 305     return unless $other->isa(__PACKAGE__);
 306
 307     my @self_type_constraints = @{$self->type_constraints||[]};
 308     my @other_type_constraints = @{$other->type_constraints||[]};
 309
 310     return unless @self_type_constraints == @other_type_constraints;
 311
 312     ## Incoming ay be either arrayref or hashref, need top compare both
 313     while(@self_type_constraints) {
 314         my $self_type_constraint = shift @self_type_constraints;
 315         my $other_type_constraint = shift @other_type_constraints;
 316
 317         $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
 318           for $self_type_constraint, $other_type_constraint;
 319
 320         return 1 if $self_type_constraint->$op($other_type_constraint);
 321     }
 322
 323     return 0;
 324 }
 325
 326 =head2 get_message
 327
 328 Give you a better peek into what's causing the error.  For now we stringify the
 329 incoming deep value with L<Devel::PartialDump> and pass that on to either your
 330 custom error message or the default one.  In the future we'll try to provide a
 331 more complete stack trace of the actual offending elements
 332
 333 =cut
 334
 335 around 'get_message' => sub {
 336     my ($get_message, $self, $value) = @_;
 337     $value = Devel::PartialDump::dump($value)
 338      if ref $value;
 339     return $self->$get_message($value);
 340 };
 341
 342 =head1 SEE ALSO
 343
 344 The following modules or resources may be of interest.
 345
 346 L<Moose>, L<Moose::Meta::TypeConstraint>
 347
 348 =head1 AUTHOR
 349
 350 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 351
 352 =head1 COPYRIGHT & LICENSE
 353
 354 This program is free software; you can redistribute it and/or modify
 355 it under the same terms as Perl itself.
 356
 357 =cut
 358
 359 __PACKAGE__->meta->make_immutable(inline_constructor => 0);