lib/MooseX/Meta/TypeConstraint/Structured.pm

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