lib/MooseX/Meta/TypeConstraint/Structured.pm

   1 package ## Hide from PAUSE
   2  MooseX::Meta::TypeConstraint::Structured;
   3
   4 use Moose;
   5 use Moose::Util::TypeConstraints ();
   6 use MooseX::Meta::TypeCoercion::Structured;
   7 extends 'Moose::Meta::TypeConstraint';
   8
   9 =head1 NAME
  10
  11 MooseX::Meta::TypeConstraint::Structured - Structured type constraints.
  12
  13 =head1 DESCRIPTION
  14
  15 A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
  16 such a way as that they are all applied to an incoming list of arguments.  The
  17 idea here is that a Type Constraint could be something like, "An Int followed by
  18 an Int and then a Str" and that this could be done so with a declaration like:
  19
  20     Tuple[Int,Int,Str]; ## Example syntax
  21
  22 So a structure is a list of Type constraints (the "Int,Int,Str" in the above
  23 example) which are intended to function together.
  24
  25 =head1 ATTRIBUTES
  26
  27 This class defines the following attributes.
  28
  29 =head2 type_constraints
  30
  31 A list of L<Moose::Meta::TypeConstraint> objects.
  32
  33 =cut
  34
  35 has 'type_constraints' => (
  36     is=>'ro',
  37     isa=>'Ref',
  38     predicate=>'has_type_constraints',
  39 );
  40
  41 =head2 constraint_generator
  42
  43 A subref or closure that contains the way we validate incoming values against
  44 a set of type constraints.
  45
  46 =cut
  47
  48 has 'constraint_generator' => (
  49     is=>'ro',
  50     isa=>'CodeRef',
  51     predicate=>'has_constraint_generator',
  52 );
  53
  54 =head1 METHODS
  55
  56 This class defines the following methods.
  57
  58 =head2 new
  59
  60 Initialization stuff.
  61
  62 =cut
  63
  64 around 'new' => sub {
  65     my ($new, $class, @args)  = @_;
  66     my $self = $class->$new(@args);
  67     $self->coercion(MooseX::Meta::TypeCoercion::Structured->new(
  68         type_constraint => $self,
  69     ));
  70     return $self;
  71 };
  72
  73 =head2 generate_constraint_for ($type_constraints)
  74
  75 Given some type constraints, use them to generate validation rules for an ref
  76 of values (to be passed at check time)
  77
  78 =cut
  79
  80 sub generate_constraint_for {
  81     my ($self, $type_constraints) = @_;
  82     return sub {
  83         my (@args) = @_;
  84         my $constraint_generator = $self->constraint_generator;
  85         return $constraint_generator->($type_constraints, @args);
  86     };
  87 }
  88
  89 =head2 parameterize (@type_constraints)
  90
  91 Given a ref of type constraints, create a structured type.
  92
  93 =cut
  94
  95 sub parameterize {
  96
  97     my ($self, @type_constraints) = @_;
  98     my $class = ref $self;
  99     my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
 100     my $constraint_generator = $self->__infer_constraint_generator;
 101
 102     return $class->new(
 103         name => $name,
 104         parent => $self,
 105         type_constraints => \@type_constraints,
 106         constraint_generator => $constraint_generator,
 107     );
 108 }
 109
 110 =head2 __infer_constraint_generator
 111
 112 This returns a CODEREF which generates a suitable constraint generator.  Not
 113 user servicable, you'll never call this directly.
 114
 115 =cut
 116
 117 sub __infer_constraint_generator {
 118     my ($self) = @_;
 119     if($self->has_constraint_generator) {
 120         return $self->constraint_generator;
 121     } else {
 122         return sub {
 123             ## I'm not sure about this stuff but everything seems to work
 124             my $tc = shift @_;
 125             my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
 126             $self->constraint->($merged_tc, @_);
 127         };
 128     }
 129 }
 130
 131 =head2 compile_type_constraint
 132
 133 hook into compile_type_constraint so we can set the correct validation rules.
 134
 135 =cut
 136
 137 around 'compile_type_constraint' => sub {
 138     my ($compile_type_constraint, $self, @args) = @_;
 139
 140     if($self->has_type_constraints) {
 141         my $type_constraints = $self->type_constraints;
 142         my $constraint = $self->generate_constraint_for($type_constraints);
 143         $self->_set_constraint($constraint);
 144     }
 145
 146     return $self->$compile_type_constraint(@args);
 147 };
 148
 149 =head2 create_child_type
 150
 151 modifier to make sure we get the constraint_generator
 152
 153 =cut
 154
 155 around 'create_child_type' => sub {
 156     my ($create_child_type, $self, %opts) = @_;
 157     return $self->$create_child_type(
 158         %opts,
 159         constraint_generator => $self->__infer_constraint_generator,
 160     );
 161 };
 162
 163 =head2 is_a_type_of
 164
 165 =head2 is_subtype_of
 166
 167 =head2 equals
 168
 169 Override the base class behavior.
 170
 171 =cut
 172
 173 sub equals {
 174     my ( $self, $type_or_name ) = @_;
 175     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 176
 177     return unless $other->isa(__PACKAGE__);
 178
 179     return (
 180         $self->type_constraints_equals($other)
 181             and
 182         $self->parent->equals( $other->parent )
 183     );
 184 }
 185
 186 =head2 type_constraints_equals
 187
 188 Checks to see if the internal type contraints are equal.
 189
 190 =cut
 191
 192 sub type_constraints_equals {
 193     my ($self, $other) = @_;
 194     my @self_type_constraints = @{$self->type_constraints||[]};
 195     my @other_type_constraints = @{$other->type_constraints||[]};
 196
 197     ## Incoming ay be either arrayref or hashref, need top compare both
 198     while(@self_type_constraints) {
 199         my $self_type_constraint = shift @self_type_constraints;
 200         my $other_type_constraint = shift @other_type_constraints
 201          || return; ## $other needs the same number of children.
 202
 203         if( ref $self_type_constraint) {
 204             $self_type_constraint->equals($other_type_constraint)
 205              || return; ## type constraints obviously need top be equal
 206         } else {
 207             $self_type_constraint eq $other_type_constraint
 208              || return; ## strings should be equal
 209         }
 210
 211     }
 212
 213     return 1; ##If we get this far, everything is good.
 214 }
 215
 216 =head2 get_message
 217
 218 May want to override this to set a more useful error message
 219
 220 =head1 SEE ALSO
 221
 222 The following modules or resources may be of interest.
 223
 224 L<Moose>, L<Moose::Meta::TypeConstraint>
 225
 226 =head1 AUTHOR
 227
 228 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 229
 230 =head1 COPYRIGHT & LICENSE
 231
 232 This program is free software; you can redistribute it and/or modify
 233 it under the same terms as Perl itself.
 234
 235 =cut
 236
 237 __PACKAGE__->meta->make_immutable;