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, $value, $message) = @_;
  70     $message = bless {message=>undef, level=>0}, 'MooseX::Types::Structured::Message'
  71       unless $message;
  72
  73     $message->{level}++;
  74
  75     if ($self->_compiled_type_constraint->($value, $message)) {
  76         ## Everything is good, no error message to return
  77         return undef;
  78     } else {
  79         ## Whoops, need to figure out the right error message
  80         my $args = Devel::PartialDump::dump($value);
  81         if(my $messages = $message->{message}) {
  82             my $level = $message->{level};
  83             my $message_str = ref $messages ? join("\n".(" "x$level)."[+] ",reverse @$messages) : $messages;
  84             $message->{level}--;
  85
  86             if($message->{level}) {
  87                 return $self->get_message($args);
  88             } else {
  89                 return $self->get_message("$args, Internal Validation Error is: $message_str");
  90             }
  91         } else {
  92             $message->{level}--;
  93
  94             return $self->get_message($args);
  95         }
  96     }
  97 };
  98
  99 =method generate_constraint_for ($type_constraints)
 100
 101 Given some type constraints, use them to generate validation rules for an ref
 102 of values (to be passed at check time)
 103
 104 =cut
 105
 106 sub generate_constraint_for {
 107     my ($self, $type_constraints) = @_;
 108     return sub {
 109         my $arg =  shift @_;
 110         my $constraint_generator = $self->constraint_generator;
 111         my $result = $constraint_generator->($type_constraints, $arg, $_[0]);
 112         return $result;
 113     };
 114 }
 115
 116 =method parameterize (@type_constraints)
 117
 118 Given a ref of type constraints, create a structured type.
 119
 120 =cut
 121
 122 sub parameterize {
 123     my ($self, @type_constraints) = @_;
 124     my $class = ref $self;
 125     my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
 126     my $constraint_generator = $self->__infer_constraint_generator;
 127
 128     return $class->new(
 129         name => $name,
 130         parent => $self,
 131         type_constraints => \@type_constraints,
 132         constraint_generator => $constraint_generator,
 133     );
 134 }
 135
 136 =method __infer_constraint_generator
 137
 138 This returns a CODEREF which generates a suitable constraint generator.  Not
 139 user servicable, you'll never call this directly.
 140
 141 =cut
 142
 143 sub __infer_constraint_generator {
 144     my ($self) = @_;
 145     if($self->has_constraint_generator) {
 146         return $self->constraint_generator;
 147     } else {
 148         return sub {
 149             ## I'm not sure about this stuff but everything seems to work
 150             my $tc = shift @_;
 151             my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
 152             $self->constraint->($merged_tc, @_);
 153         };
 154     }
 155 }
 156
 157 =method compile_type_constraint
 158
 159 hook into compile_type_constraint so we can set the correct validation rules.
 160
 161 =cut
 162
 163 around 'compile_type_constraint' => sub {
 164     my ($compile_type_constraint, $self, @args) = @_;
 165
 166     if($self->has_type_constraints) {
 167         my $type_constraints = $self->type_constraints;
 168         my $constraint = $self->generate_constraint_for($type_constraints);
 169         $self->_set_constraint($constraint);
 170     }
 171
 172     return $self->$compile_type_constraint(@args);
 173 };
 174
 175 =method create_child_type
 176
 177 modifier to make sure we get the constraint_generator
 178
 179 =cut
 180
 181 around 'create_child_type' => sub {
 182     my ($create_child_type, $self, %opts) = @_;
 183     return $self->$create_child_type(
 184         %opts,
 185         constraint_generator => $self->__infer_constraint_generator,
 186     );
 187 };
 188
 189 =method is_a_type_of
 190
 191 =method is_subtype_of
 192
 193 =method equals
 194
 195 Override the base class behavior.
 196
 197 =cut
 198
 199 sub equals {
 200     my ( $self, $type_or_name ) = @_;
 201     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 202
 203     return unless $other->isa(__PACKAGE__);
 204
 205     return (
 206         $self->parent->equals($other->parent)
 207             and
 208         $self->type_constraints_equals($other)
 209     );
 210 }
 211
 212 sub is_a_type_of {
 213     my ( $self, $type_or_name ) = @_;
 214     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 215
 216     if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) {
 217         if ( $self->parent->is_a_type_of($other->parent) ) {
 218             return $self->_type_constraints_op_all($other, "is_a_type_of");
 219         } elsif ( $self->parent->is_a_type_of($other) ) {
 220             return 1;
 221             # FIXME compare?
 222         } else {
 223             return 0;
 224         }
 225     } else {
 226         return $self->SUPER::is_a_type_of($other);
 227     }
 228 }
 229
 230 sub is_subtype_of {
 231     my ( $self, $type_or_name ) = @_;
 232     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 233     if ( $other->isa(__PACKAGE__) ) {
 234         if ( $other->type_constraints and $self->type_constraints ) {
 235             if ( $self->parent->is_a_type_of($other->parent) ) {
 236                 return (
 237                     $self->_type_constraints_op_all($other, "is_a_type_of")
 238                       and
 239                     $self->_type_constraints_op_any($other, "is_subtype_of")
 240                 );
 241             } elsif ( $self->parent->is_a_type_of($other) ) {
 242                 return 1;
 243                 # FIXME compare?
 244             } else {
 245                 return 0;
 246             }
 247         } else {
 248             if ( $self->type_constraints ) {
 249                 if ( $self->SUPER::is_subtype_of($other) ) {
 250                     return 1;
 251                 } else {
 252                     return;
 253                 }
 254             } else {
 255                 return $self->parent->is_subtype_of($other->parent);
 256             }
 257         }
 258     } else {
 259         return $self->SUPER::is_subtype_of($other);
 260     }
 261 }
 262
 263 =method type_constraints_equals
 264
 265 Checks to see if the internal type constraints are equal.
 266
 267 =cut
 268
 269 sub type_constraints_equals {
 270     my ( $self, $other ) = @_;
 271     $self->_type_constraints_op_all($other, "equals");
 272 }
 273
 274 sub _type_constraints_op_all {
 275     my ($self, $other, $op) = @_;
 276
 277     return unless $other->isa(__PACKAGE__);
 278
 279     my @self_type_constraints = @{$self->type_constraints||[]};
 280     my @other_type_constraints = @{$other->type_constraints||[]};
 281
 282     return unless @self_type_constraints == @other_type_constraints;
 283
 284     ## Incoming ay be either arrayref or hashref, need top compare both
 285     while(@self_type_constraints) {
 286         my $self_type_constraint = shift @self_type_constraints;
 287         my $other_type_constraint = shift @other_type_constraints;
 288
 289         $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
 290           for $self_type_constraint, $other_type_constraint;
 291
 292         my $result = $self_type_constraint->$op($other_type_constraint);
 293         return unless $result;
 294     }
 295
 296     return 1; ##If we get this far, everything is good.
 297 }
 298
 299 sub _type_constraints_op_any {
 300     my ($self, $other, $op) = @_;
 301
 302     return unless $other->isa(__PACKAGE__);
 303
 304     my @self_type_constraints = @{$self->type_constraints||[]};
 305     my @other_type_constraints = @{$other->type_constraints||[]};
 306
 307     return unless @self_type_constraints == @other_type_constraints;
 308
 309     ## Incoming ay be either arrayref or hashref, need top compare both
 310     while(@self_type_constraints) {
 311         my $self_type_constraint = shift @self_type_constraints;
 312         my $other_type_constraint = shift @other_type_constraints;
 313
 314         $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
 315           for $self_type_constraint, $other_type_constraint;
 316
 317         return 1 if $self_type_constraint->$op($other_type_constraint);
 318     }
 319
 320     return 0;
 321 }
 322
 323 =method get_message
 324
 325 Give you a better peek into what's causing the error.  For now we stringify the
 326 incoming deep value with L<Devel::PartialDump> and pass that on to either your
 327 custom error message or the default one.  In the future we'll try to provide a
 328 more complete stack trace of the actual offending elements
 329
 330 =cut
 331
 332 around 'get_message' => sub {
 333     my ($get_message, $self, $value) = @_;
 334     $value = Devel::PartialDump::dump($value)
 335      if ref $value;
 336     return $self->$get_message($value);
 337 };
 338
 339 =head1 SEE ALSO
 340
 341 The following modules or resources may be of interest.
 342
 343 L<Moose>, L<Moose::Meta::TypeConstraint>
 344
 345 =cut
 346
 347 __PACKAGE__->meta->make_immutable(inline_constructor => 0);