lib/Moose/Meta/TypeCoercion.pm

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