lib/Moose/Meta/TypeConstraint/Intersection.pm

   1
   2 package Moose::Meta::TypeConstraint::Intersection;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Moose::Meta::TypeCoercion::Intersection;
   9
  10 use List::Util qw(first);
  11 use List::MoreUtils qw(all);
  12
  13 use base 'Moose::Meta::TypeConstraint';
  14
  15 __PACKAGE__->meta->add_attribute('type_constraints' => (
  16     accessor  => 'type_constraints',
  17     default   => sub { [] },
  18     Class::MOP::_definition_context(),
  19 ));
  20
  21 sub new {
  22     my ($class, %options) = @_;
  23
  24     my $name = join '&' => sort {$a cmp $b}
  25          map { $_->name } @{$options{type_constraints}};
  26
  27     my $self = $class->SUPER::new(
  28         name     => $name,
  29         %options,
  30     );
  31     $self->_set_constraint(sub { $self->check($_[0]) });
  32     $self->coercion(Moose::Meta::TypeCoercion::Intersection->new(
  33         type_constraint => $self
  34     ));
  35     return $self;
  36 }
  37
  38 sub _actually_compile_type_constraint {
  39     my $self = shift;
  40
  41     my @constraints = @{ $self->type_constraints };
  42
  43     return sub {
  44       my $value = shift;
  45       my $count = 0;
  46       foreach my $type (@constraints){
  47         $count++ if $type->check($value);
  48       }
  49       return $count==scalar @constraints ? 1: undef;
  50     };
  51 }
  52
  53 sub can_be_inlined {
  54     my $self = shift;
  55     for my $tc ( @{ $self->type_constraints }) {
  56       return 0 unless $tc->can_be_inlined;
  57     }
  58     return 1;
  59 }
  60
  61 sub _inline_check {
  62     my $self = shift;
  63     my $val  = shift;
  64     return '(' .
  65       (
  66         join ' && ' , map { '(' . $_->_inline_check($val) . ')' } @{ $self->type_constraints }
  67       ) . ')';
  68 }
  69
  70 sub inline_environment {
  71     my $self = shift;
  72
  73     return { map { %{ $_->inline_environment } } @{ $self->type_constraints } };
  74 }
  75
  76 sub equals {
  77     my ( $self, $type_or_name ) = @_;
  78
  79     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  80
  81     return unless $other->isa(__PACKAGE__);
  82
  83     my @self_constraints  = @{ $self->type_constraints };
  84     my @other_constraints = @{ $other->type_constraints };
  85
  86     return unless @self_constraints == @other_constraints;
  87
  88     # FIXME presort type constraints for efficiency?
  89     constraint: foreach my $constraint ( @self_constraints ) {
  90         for ( my $i = 0; $i < @other_constraints; $i++ ) {
  91             if ( $constraint->equals($other_constraints[$i]) ) {
  92                 splice @other_constraints, $i, 1;
  93                 next constraint;
  94             }
  95         }
  96     }
  97
  98     return @other_constraints == 0;
  99 }
 100
 101 sub parents {
 102     my $self = shift;
 103     $self->type_constraints;
 104 }
 105
 106 sub validate {
 107     my ($self, $value) = @_;
 108     my $message;
 109     foreach my $type (@{$self->type_constraints}) {
 110         my $err = $type->validate($value);
 111         return unless defined $err;
 112         $message .= ($message ? ' and ' : '') . $err
 113             if defined $err;
 114     }
 115     return ($message . ' in (' . $self->name . ')') ;
 116 }
 117
 118 sub find_type_for {
 119     my ($self, $value) = @_;
 120     return first { $_->check($value) } @{ $self->type_constraints };
 121 }
 122
 123 sub is_a_type_of {
 124     my ($self, $type_name) = @_;
 125     foreach my $type (@{$self->type_constraints}) {
 126         return 1 if $type->is_a_type_of($type_name);
 127     }
 128     return 0;
 129 }
 130
 131 sub is_subtype_of {
 132     my ($self, $type_name) = @_;
 133     foreach my $type (@{$self->type_constraints}) {
 134         return 1 if $type->is_subtype_of($type_name);
 135     }
 136     return 0;
 137 }
 138
 139 sub create_child_type {
 140     my ( $self, %opts ) = @_;
 141
 142     my $constraint
 143         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 144
 145     # if we have a type constraint intersection, and no
 146     # type check, this means we are just aliasing
 147     # the intersection constraint, which means we need to
 148     # handle this differently.
 149     # - SL
 150     if ( not( defined $opts{constraint} )
 151         && $self->has_coercion ) {
 152         $constraint->coercion(
 153             Moose::Meta::TypeCoercion::Intersection->new(
 154                 type_constraint => $self,
 155             )
 156         );
 157     }
 158
 159     return $constraint;
 160 }
 161
 162 1;
 163
 164 __END__
 165
 166 =pod
 167
 168 =head1 NAME
 169
 170 Moose::Meta::TypeConstraint::Intersection - An intersection of Moose type constraints
 171
 172 =head1 DESCRIPTION
 173
 174 This metaclass represents an intersection of Moose type constraints. More
 175 details to be explained later (possibly in a Cookbook recipe).
 176
 177 This actually used to be part of Moose::Meta::TypeConstraint, but it
 178 is now better off in it's own file.
 179
 180 =head1 METHODS
 181
 182 This class is not a subclass of Moose::Meta::TypeConstraint,
 183 but it does provide the same API
 184
 185 =over 4
 186
 187 =item B<meta>
 188
 189 =item B<new>
 190
 191 =item B<name>
 192
 193 =item B<type_constraints>
 194
 195 =item B<parents>
 196
 197 =item B<constraint>
 198
 199 =item B<includes_type>
 200
 201 =item B<equals>
 202
 203 =back
 204
 205 =head2 Overridden methods
 206
 207 =over 4
 208
 209 =item B<check>
 210
 211 =item B<coerce>
 212
 213 =item B<validate>
 214
 215 =item B<is_a_type_of>
 216
 217 =item B<is_subtype_of>
 218
 219 =back
 220
 221 =head2 Empty or Stub methods
 222
 223 These methods tend to not be very relevant in
 224 the context of an intersection. Either that or they are
 225 just difficult to specify and not very useful
 226 anyway. They are here for completeness.
 227
 228 =over 4
 229
 230 =item B<parent>
 231
 232 =item B<coercion>
 233
 234 =item B<has_coercion>
 235
 236 =item B<message>
 237
 238 =item B<has_message>
 239
 240 =item B<hand_optimized_type_constraint>
 241
 242 =item B<has_hand_optimized_type_constraint>
 243
 244 =item B<create_child_type>
 245
 246 =back
 247
 248 =head1 BUGS
 249
 250 All complex software has bugs lurking in it, and this module is no
 251 exception. If you find a bug please either email me, or add the bug
 252 to cpan-RT.
 253
 254 =head1 AUTHOR
 255
 256 Stevan Little E<lt>stevan@iinteractive.comE<gt> and
 257 Adam Foxson E<lt>afoxson@pobox.comE<gt>
 258
 259 =head1 COPYRIGHT AND LICENSE
 260
 261 Copyright 2006-2009 by Infinity Interactive, Inc.
 262
 263 L<http://www.iinteractive.com>
 264
 265 This library is free software; you can redistribute it and/or modify
 266 it under the same terms as Perl itself.
 267
 268 =cut