lib/Moose/Meta/TypeCoercion.pm

   1
   2 package Moose::Meta::TypeCoercion;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Moose::Meta::Attribute;
   9 use Moose::Util::TypeConstraints ();
  10
  11 our $VERSION   = '0.67';
  12 $VERSION = eval $VERSION;
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 __PACKAGE__->meta->add_attribute('type_coercion_map' => (
  16     reader  => 'type_coercion_map',
  17     default => sub { [] }
  18 ));
  19
  20 __PACKAGE__->meta->add_attribute(
  21     Moose::Meta::Attribute->new('type_constraint' => (
  22         reader   => 'type_constraint',
  23         weak_ref => 1
  24     ))
  25 );
  26
  27 # private accessor
  28 __PACKAGE__->meta->add_attribute('compiled_type_coercion' => (
  29     accessor => '_compiled_type_coercion'
  30 ));
  31
  32 sub new {
  33     my $class = shift;
  34     my $self  = $class->meta->new_object(@_);
  35     $self->compile_type_coercion;
  36     return $self;
  37 }
  38
  39 sub compile_type_coercion {
  40     my $self = shift;
  41     my @coercion_map = @{$self->type_coercion_map};
  42     my @coercions;
  43     while (@coercion_map) {
  44         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
  45         my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
  46         (defined $type_constraint)
  47             || Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
  48         push @coercions => [
  49             $type_constraint->_compiled_type_constraint,
  50             $action
  51         ];
  52     }
  53     $self->_compiled_type_coercion(sub {
  54         my $thing = shift;
  55         foreach my $coercion (@coercions) {
  56             my ($constraint, $converter) = @$coercion;
  57             if ($constraint->($thing)) {
  58                 local $_ = $thing;
  59                 return $converter->($thing);
  60             }
  61         }
  62         return $thing;
  63     });
  64 }
  65
  66 sub has_coercion_for_type {
  67     my ($self, $type_name) = @_;
  68     my %coercion_map = @{$self->type_coercion_map};
  69     exists $coercion_map{$type_name} ? 1 : 0;
  70 }
  71
  72 sub add_type_coercions {
  73     my ($self, @new_coercion_map) = @_;
  74
  75     my $coercion_map = $self->type_coercion_map;
  76     my %has_coercion = @$coercion_map;
  77
  78     while (@new_coercion_map) {
  79         my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2);
  80
  81         Moose->throw_error("A coercion action already exists for '$constraint_name'")
  82             if exists $has_coercion{$constraint_name};
  83
  84         push @{$coercion_map} => ($constraint_name, $action);
  85     }
  86
  87     # and re-compile ...
  88     $self->compile_type_coercion;
  89 }
  90
  91 sub coerce { $_[0]->_compiled_type_coercion->($_[1]) }
  92
  93
  94 1;
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 NAME
 101
 102 Moose::Meta::TypeCoercion - The Moose Type Coercion metaclass
 103
 104 =head1 DESCRIPTION
 105
 106 For the most part, the only time you will ever encounter an
 107 instance of this class is if you are doing some serious deep
 108 introspection. This API should not be considered final, but
 109 it is B<highly unlikely> that this will matter to a regular
 110 Moose user.
 111
 112 If you wish to use features at this depth, please come to the
 113 #moose IRC channel on irc.perl.org and we can talk :)
 114
 115 =head1 METHODS
 116
 117 =over 4
 118
 119 =item B<meta>
 120
 121 =item B<new>
 122
 123 =item B<compile_type_coercion>
 124
 125 =item B<coerce>
 126
 127 =item B<type_coercion_map>
 128
 129 =item B<type_constraint>
 130
 131 =item B<has_coercion_for_type>
 132
 133 =item B<add_type_coercions>
 134
 135 =back
 136
 137 =head1 BUGS
 138
 139 All complex software has bugs lurking in it, and this module is no
 140 exception. If you find a bug please either email me, or add the bug
 141 to cpan-RT.
 142
 143 =head1 AUTHOR
 144
 145 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 146
 147 =head1 COPYRIGHT AND LICENSE
 148
 149 Copyright 2006-2009 by Infinity Interactive, Inc.
 150
 151 L<http://www.iinteractive.com>
 152
 153 This library is free software; you can redistribute it and/or modify
 154 it under the same terms as Perl itself.
 155
 156 =cut