lib/Moose/Meta/TypeCoercion/Union.pm

   1
   2 package Moose::Meta::TypeCoercion::Union;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Carp         'confess';
   9 use Scalar::Util 'blessed';
  10
  11 our $VERSION   = '0.01';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Moose::Meta::TypeCoercion';
  15
  16 sub compile_type_coercion {
  17     my $self            = shift;
  18     my $type_constraint = $self->type_constraint;
  19
  20     (blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union'))
  21      || confess "You can only a Moose::Meta::TypeCoercion::Union for a " .
  22                 "Moose::Meta::TypeConstraint::Union, not a $type_constraint";
  23
  24     $self->_compiled_type_coercion(sub {
  25         my $value = shift;
  26         # go through all the type constraints
  27         # in the union, and check em ...
  28         foreach my $type (@{$type_constraint->type_constraints}) {
  29             # if they have a coercion first
  30             if ($type->has_coercion) {
  31                 # then try to coerce them ...
  32                 my $temp = $type->coerce($value);
  33                 # and if they get something
  34                 # make sure it still fits within
  35                 # the union type ...
  36                 return $temp if $type_constraint->check($temp);
  37             }
  38         }
  39         return undef;
  40     });
  41 }
  42
  43 1;
  44
  45 __END__
  46
  47 =pod
  48
  49 =head1 NAME
  50
  51 Moose::Meta::TypeCoercion::Union - The Moose Type Coercion metaclass for Unions
  52
  53 =head1 DESCRIPTION
  54
  55 For the most part, the only time you will ever encounter an
  56 instance of this class is if you are doing some serious deep
  57 introspection. This API should not be considered final, but
  58 it is B<highly unlikely> that this will matter to a regular
  59 Moose user.
  60
  61 If you wish to use features at this depth, please come to the
  62 #moose IRC channel on irc.perl.org and we can talk :)
  63
  64 =head1 METHODS
  65
  66 =over 4
  67
  68 =item B<meta>
  69
  70 =item B<compile_type_coercion>
  71
  72 =back
  73
  74 =head1 BUGS
  75
  76 All complex software has bugs lurking in it, and this module is no
  77 exception. If you find a bug please either email me, or add the bug
  78 to cpan-RT.
  79
  80 =head1 AUTHOR
  81
  82 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  83
  84 =head1 COPYRIGHT AND LICENSE
  85
  86 Copyright 2006, 2007 by Infinity Interactive, Inc.
  87
  88 L<http://www.iinteractive.com>
  89
  90 This library is free software; you can redistribute it and/or modify
  91 it under the same terms as Perl itself.
  92
  93 =cut