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