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
  20
  21 =cut
  22
  23 sub coerce {
  24     my $self = shift @_;
  25     my $coderef = $self->_compiled_type_coercion;
  26     return $coderef->(@_);
  27 }
  28
  29 around 'add_type_coercions' => sub {
  30     my ($add_type_coercions, $self, @args) = @_;
  31     if($self->type_constraint->has_constraining_value) {
  32         Moose->throw_error("Cannot add type coercions to a dependent type constraint that's been defined.");
  33     } else {
  34         return $self->$add_type_coercions(@args);
  35     }
  36 };
  37
  38 sub compile_type_coercion {
  39     my $self = shift;
  40     my @coercion_map = @{$self->type_coercion_map};
  41     my @coercions;
  42     while (@coercion_map) {
  43         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
  44         my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
  45
  46         unless ( defined $type_constraint ) {
  47             require Moose;
  48             Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
  49         }
  50
  51         push @coercions => [
  52             $type_constraint->_compiled_type_constraint,
  53             $action
  54         ];
  55     }
  56     $self->_compiled_type_coercion(sub {
  57         my $thing = shift;
  58         foreach my $coercion (@coercions) {
  59             my ($constraint, $converter) = @$coercion;
  60             if ($constraint->($thing)) {
  61                 local $_ = $thing;
  62                 return $converter->($thing, @_);
  63             }
  64         }
  65         return $thing;
  66     });
  67 }
  68
  69
  70
  71
  72 =head1 SEE ALSO
  73
  74 The following modules or resources may be of interest.
  75
  76 L<Moose>, L<Moose::Meta::TypeCoercion>
  77
  78 =head1 AUTHOR
  79
  80 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
  81
  82 =head1 COPYRIGHT & LICENSE
  83
  84 This program is free software; you can redistribute it and/or modify
  85 it under the same terms as Perl itself.
  86
  87 =cut
  88
  89 __PACKAGE__->meta->make_immutable;