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