lib/MooseX/Meta/TypeCoercion/Parameterizable.pm

   1 package ## Hide from PAUSE
   2  MooseX::Meta::TypeCoercion::Parameterizable;
   3
   4 use Moose;
   5 extends 'Moose::Meta::TypeCoercion';
   6
   7 =head1 NAME
   8
   9 MooseX::Meta::TypeCoercion::Parameterizable - Coerce Parameterizable type constraints.
  10
  11 =head1 DESCRIPTION
  12
  13 Coercion Meta Class, intended to make sure coercions work correctly with
  14 parameterized types.  You probably won't consume or subclass this class directly
  15
  16 =head1 METHODS
  17
  18 This class defines the following methods.
  19
  20 =head add_type_coercions
  21
  22 method modification to throw exception should we try to add a coercion on a
  23 parameterizable type that is already defined by a constraining value.  We do
  24 this since defined parameterizable type constraints inherit their coercion from
  25 the parent constraint.  It makes no sense to even be using parameterizable
  26 types if you know the constraining value beforehand!
  27
  28 =cut
  29
  30 around 'add_type_coercions' => sub {
  31     my ($add_type_coercions, $self, @args) = @_;
  32     if($self->type_constraint->has_constraining_value) {
  33         Moose->throw_error("Cannot add type coercions to a parameterizable type constraint that's been defined.");
  34     } else {
  35         return $self->$add_type_coercions(@args);
  36     }
  37 };
  38
  39
  40 ## These two are here until I can merge change upstream to Moose.  These are two
  41 ## very minor changes we can probably just put into Moose without breaking stuff.
  42 ## Hopefully can can eventually stop doing this.
  43
  44 sub coerce {
  45     my $self = shift @_;
  46     my $coderef = $self->_compiled_type_coercion;
  47     return $coderef->(@_); ## <== in Moose we don't call on @_, but $_[1]
  48 }
  49
  50 sub compile_type_coercion {
  51     my $self = shift;
  52     my @coercion_map = @{$self->type_coercion_map};
  53     my @coercions;
  54     while (@coercion_map) {
  55         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
  56
  57         my $type_constraint = ref $constraint_name
  58                             ? $constraint_name
  59                             : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
  60
  61         unless ( defined $type_constraint ) {
  62             require Moose;
  63             Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
  64         }
  65
  66         push @coercions => [
  67             $type_constraint->_compiled_type_constraint,
  68             $action
  69         ];
  70     }
  71     $self->_compiled_type_coercion(sub {
  72         my $thing = shift;
  73         foreach my $coercion (@coercions) {
  74             my ($constraint, $converter) = @$coercion;
  75             if ($constraint->($thing)) {
  76                 local $_ = $thing;
  77                 return $converter->($thing, @_); ## <== Here also we pass @_ which Moose doesn't
  78             }
  79         }
  80         return $thing;
  81     });
  82 }
  83
  84 =head1 SEE ALSO
  85
  86 The following modules or resources may be of interest.
  87
  88 L<Moose>, L<Moose::Meta::TypeCoercion>
  89
  90 =head1 AUTHOR
  91
  92 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
  93
  94 =head1 COPYRIGHT & LICENSE
  95
  96 This program is free software; you can redistribute it and/or modify
  97 it under the same terms as Perl itself.
  98
  99 =cut
 100
 101 __PACKAGE__->meta->make_immutable(inline_constructor => 0);