local-lib5/lib/perl5/MooseX/Meta/TypeConstraint/ForceCoercion.pm

   1 package MooseX::Meta::TypeConstraint::ForceCoercion;
   2 our $VERSION = '0.01';
   3
   4 # ABSTRACT: Force coercion when validating type constraints
   5
   6 use Moose;
   7 use namespace::autoclean;
   8
   9
  10
  11 has _type_constraint => (
  12     is       => 'ro',
  13     isa      => 'Moose::Meta::TypeConstraint',
  14     init_arg => 'type_constraint',
  15     required => 1,
  16 );
  17
  18
  19 sub check {
  20     my ($self, $value) = @_;
  21     my $coerced = $self->_type_constraint->coerce($value);
  22     return undef if $coerced == $value;
  23     return $self->_type_constraint->check($coerced);
  24 }
  25
  26
  27 sub validate {
  28     my ($self, $value, $coerced_ref) = @_;
  29     my $coerced = $self->_type_constraint->coerce($value);
  30     return 'Coercion failed' if $coerced == $value;
  31     ${ $coerced_ref } = $coerced if $coerced_ref;
  32     return $self->_type_constraint->validate($coerced);
  33 }
  34
  35 my $meta = __PACKAGE__->meta;
  36
  37 for my $meth (qw/isa can meta/) {
  38     my $orig = __PACKAGE__->can($meth);
  39     $meta->add_method($meth => sub {
  40         my ($self) = shift;
  41         return $self->$orig(@_) unless blessed $self;
  42
  43         my $tc = $self->_type_constraint;
  44         # this might happen during global destruction
  45         return $self->$orig(@_) unless $tc;
  46
  47         return $tc->$meth(@_);
  48     });
  49 }
  50
  51 sub AUTOLOAD {
  52     my $self = shift;
  53     my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/);
  54     return unless blessed $self;
  55
  56     my $tc = $self->_type_constraint;
  57     return unless $tc;
  58
  59     return $tc->$meth(@_);
  60 }
  61
  62 $meta->make_immutable;
  63
  64 1;
  65
  66 __END__
  67 =head1 NAME
  68
  69 MooseX::Meta::TypeConstraint::ForceCoercion - Force coercion when validating type constraints
  70
  71 =head1 VERSION
  72
  73 version 0.01
  74
  75 =head1 SYNOPSIS
  76
  77     use MooseX::Types:::Moose qw/Str Any/;
  78     use Moose::Util::TypeConstraints;
  79     use MooseX::Meta::TypeConstraint::ForceCoercion;
  80
  81     # get any type constraint
  82     my $tc = Str;
  83
  84     # declare one or more coercions for it
  85     coerce $tc,
  86         from Any,
  87         via { ... };
  88
  89     # wrap the $tc to force coercion
  90     my $coercing_tc = MooseX::Meta::TypeConstraint::ForceCoercion->new(
  91         type_constraint => $tc,
  92     );
  93
  94     # check a value against new type constraint. this will run the type
  95     # coercions for the wrapped type, even if the value already passes
  96     # validation before coercion. it will fail if the value couldn't be
  97     # coerced
  98     $coercing_tc->check('Affe');
  99
 100 =head1 DESCRIPTION
 101
 102 This class allows to wrap any C<Moose::Meta::TypeConstraint> in a way that will
 103 force coercion of the value when checking or validating a value against it.
 104
 105
 106
 107 =head1 ATTRIBUTES
 108
 109 =head2 type_constraint
 110
 111 The type constraint to wrap. All methods except for C<validate> and C<check>
 112 are delegated to the value of this attribute.
 113
 114
 115
 116 =head1 METHODS
 117
 118 =head2 check ($value)
 119
 120 Same as C<Moose::Meta::TypeConstraint::check>, except it will always try to
 121 coerce C<$value> before checking it against the actual type constraint. If
 122 coercing fails the check will fail, too.
 123
 124
 125
 126 =head2 validate ($value, $coerced_ref?)
 127
 128 Same as C<Moose::Meta::TypeConstraint::validate>, except it will always try to
 129 coerce C<$value> before validating it against the actual type constraint. If
 130 coercing fails the validation will fail, too.
 131
 132 If coercion was successful and a C<$coerced_ref> references was passed, the
 133 coerced value will be stored in that.
 134
 135 =head1 AUTHOR
 136
 137   Florian Ragwitz <rafl@debian.org>
 138
 139 =head1 COPYRIGHT AND LICENSE
 140
 141 This software is copyright (c) 2009 by Florian Ragwitz.
 142
 143 This is free software; you can redistribute it and/or modify it under
 144 the same terms as perl itself.
 145