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.02';
  14
  15 __PACKAGE__->meta->add_attribute('type_coercion_map' => (
  16     reader  => 'type_coercion_map',
  17     default => sub { [] }
  18 ));
  19 __PACKAGE__->meta->add_attribute(
  20     Moose::Meta::Attribute->new('type_constraint' => (
  21         reader   => 'type_constraint',
  22         weak_ref => 1
  23     ))
  24 );
  25
  26 # private accessor
  27 __PACKAGE__->meta->add_attribute('compiled_type_coercion' => (
  28     accessor => '_compiled_type_coercion'
  29 ));
  30
  31 sub new {
  32     my $class = shift;
  33     my $self  = $class->meta->new_object(@_);
  34     $self->compile_type_coercion();
  35     return $self;
  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 = Moose::Util::TypeConstraints::find_type_constraint($constraint_name);
  45         (defined $type_constraint)
  46             || confess "Could not find the type constraint ($constraint_name) to coerce from";
  47         push @coercions => [
  48             $type_constraint->_compiled_type_constraint,
  49             $action
  50         ];
  51     }
  52     $self->_compiled_type_coercion(sub {
  53         my $thing = shift;
  54         foreach my $coercion (@coercions) {
  55             my ($constraint, $converter) = @$coercion;
  56             if (defined $constraint->($thing)) {
  57                             local $_ = $thing;
  58                 return $converter->($thing);
  59             }
  60         }
  61         return $thing;
  62     });
  63 }
  64
  65 sub coerce { $_[0]->_compiled_type_coercion->($_[1]) }
  66
  67
  68 1;
  69
  70 __END__
  71
  72 =pod
  73
  74 =head1 NAME
  75
  76 Moose::Meta::TypeCoercion - The Moose Type Coercion metaclass
  77
  78 =head1 DESCRIPTION
  79
  80 For the most part, the only time you will ever encounter an
  81 instance of this class is if you are doing some serious deep
  82 introspection. This API should not be considered final, but
  83 it is B<highly unlikely> that this will matter to a regular
  84 Moose user.
  85
  86 If you wish to use features at this depth, please come to the
  87 #moose IRC channel on irc.perl.org and we can talk :)
  88
  89 =head1 METHODS
  90
  91 =over 4
  92
  93 =item B<meta>
  94
  95 =item B<new>
  96
  97 =item B<compile_type_coercion>
  98
  99 =item B<coerce>
 100
 101 =item B<type_coercion_map>
 102
 103 =item B<type_constraint>
 104
 105 =back
 106
 107 =head1 BUGS
 108
 109 All complex software has bugs lurking in it, and this module is no
 110 exception. If you find a bug please either email me, or add the bug
 111 to cpan-RT.
 112
 113 =head1 AUTHOR
 114
 115 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 116
 117 =head1 COPYRIGHT AND LICENSE
 118
 119 Copyright 2006 by Infinity Interactive, Inc.
 120
 121 L<http://www.iinteractive.com>
 122
 123 This library is free software; you can redistribute it and/or modify
 124 it under the same terms as Perl itself.
 125
 126 =cut