lib/MooseX/Dependent/Meta/TypeCoercion/Dependent.pm

   1 package ## Hide from PAUSE
   2  MooseX::Dependent::Meta::TypeCoercion::Dependent;
   3
   4 use Moose;
   5 extends 'Moose::Meta::TypeCoercion';
   6
   7 =head1 NAME
   8
   9 MooseX::Meta::TypeCoercion::Dependent - Coerce Dependent type constraints.
  10
  11 =head1 DESCRIPTION
  12
  13 TBD
  14
  15 =head1 METHODS
  16
  17 This class defines the following methods.
  18
  19 =head add_type_coercions
  20
  21 method modification to throw exception should we try to add a coercion on a
  22 dependent type that's had it's constraining value filled
  23
  24 =cut
  25
  26 around 'add_type_coercions' => sub {
  27     my ($add_type_coercions, $self, @args) = @_;
  28     if($self->type_constraint->has_constraining_value) {
  29         Moose->throw_error("Cannot add type coercions to a dependent type constraint that's been defined.");
  30     } else {
  31         return $self->$add_type_coercions(@args);
  32     }
  33 };
  34
  35
  36 ## These two are here until I can merge change upstream to Moose
  37 sub coerce {
  38     my $self = shift @_;
  39     my $coderef = $self->_compiled_type_coercion;
  40     return $coderef->(@_);
  41 }
  42
  43 sub compile_type_coercion {
  44     my $self = shift;
  45     my @coercion_map = @{$self->type_coercion_map};
  46     my @coercions;
  47     while (@coercion_map) {
  48         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
  49         my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
  50
  51         unless ( defined $type_constraint ) {
  52             require Moose;
  53             Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
  54         }
  55
  56         push @coercions => [
  57             $type_constraint->_compiled_type_constraint,
  58             $action
  59         ];
  60     }
  61     $self->_compiled_type_coercion(sub {
  62         my $thing = shift;
  63         foreach my $coercion (@coercions) {
  64             my ($constraint, $converter) = @$coercion;
  65             if ($constraint->($thing)) {
  66                 local $_ = $thing;
  67                 return $converter->($thing, @_);
  68             }
  69         }
  70         return $thing;
  71     });
  72 }
  73
  74 =head1 SEE ALSO
  75
  76 The following modules or resources may be of interest.
  77
  78 L<Moose>, L<Moose::Meta::TypeCoercion>
  79
  80 =head1 AUTHOR
  81
  82 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
  83
  84 =head1 COPYRIGHT & LICENSE
  85
  86 This program is free software; you can redistribute it and/or modify
  87 it under the same terms as Perl itself.
  88
  89 =cut
  90
  91 __PACKAGE__->meta->make_immutable;