# @(#)$Id: Constraints.pm 174 2013-01-23 16:24:25Z pjf $
use strict;
use charnames qw(:full);
use version; our $VERSION = qv( sprintf '0.9.%d', q$Rev: 174 $ =~ /\d+/gmx );
use Moose;
use Regexp::Common qw(number);
use Scalar::Util qw(looks_like_number);
has 'error' => is => q(rw), isa => q(Str);
has 'max_length' => is => q(rw), isa => q(Int);
has 'max_value' => is => q(rw), isa => q(Int);
has 'min_length' => is => q(rw), isa => q(Int);
has 'min_value' => is => q(rw), isa => q(Int);
has 'required' => is => q(rw), isa => q(Bool);
has 'value' => is => q(rw), isa => q(Any);
sub validate {
my ($self, $val) = @_; my $method = $self->method; my $class;
return 0 if (!$val && $self->required);
return 1 if (!$val && !$self->required && $method ne q(isMandatory));
return $self->$method( $val ) if ($self->can( $method ));
return $self->_load_class( q(isValid), $method )->_validate( $val );
}
# Private methods
sub _validate {
my $self = shift; my $exception = $self->exception;
$exception->throw( error => 'Method [_1] not overridden in class [_2]',
args => [ q(_validate), ref $self || $self ] );
return;
}
# Builtin factory validation methods
sub isBetweenValues {
my ($self, $val) = @_;
return 0 if (defined $self->min_value && $val < $self->min_value);
return 0 if (defined $self->max_value && $val > $self->max_value);
return 1;
}
sub isEqualTo {
my ($self, $val) = @_;
if ($self->isValidNumber( $val ) && $self->isValidNumber( $self->value )) {
return 1 if ($val == $self->value);
return 0;
}
return 1 if ($val eq $self->value);
return 0;
}
sub isHexadecimal {
my ($self, $val) = @_;
$self->pattern( '\A '.$RE{num}{hex}.' \z' );
return $self->isMatchingRegex( $val );
}
sub isMandatory {
return defined $_[ 1 ] && length $_[ 1 ] ? 1 : 0;
}
sub isMatchingRegex {
my ($self, $val) = @_; my $pat = $self->pattern;
return $val =~ m{ $pat }msx ? 1 : 0;
}
sub isPrintable {
$_[ 0 ]->pattern( '\A \p{IsPrint}+ \z' );
return $_[ 0 ]->isMatchingRegex( $_[ 1 ] );
}
sub isSimpleText {
$_[ 0 ]->pattern( '\A [a-zA-Z0-9_ \-\.]+ \z' );
return $_[ 0 ]->isMatchingRegex( $_[ 1 ] );
}
sub isValidHostname {
return (gethostbyname $_[ 1 ])[ 0 ] ? 1 : 0;
}
sub isValidIdentifier {
$_[ 0 ]->pattern( '\A [a-zA-Z_] \w* \z' );
return $_[ 0 ]->isMatchingRegex( $_[ 1 ] );
}
sub isValidInteger {
my ($self, $val) = @_;
$self->pattern( '\A '.$RE{num}{int}{-sep=>'[_]?'}.' \z' );
return 0 unless ($self->isMatchingRegex( $val ));
return 0 unless (int $val == $val);
return 1;
}
sub isValidLength {
my ($self, $val) = @_;
return 0 if (defined $self->min_length && length $val < $self->min_length);
return 0 if (defined $self->max_length && length $val > $self->max_length);
return 1;
}
sub isValidNumber {
return 0 unless (defined $_[ 1 ]);
return 1 if (looks_like_number( $_[ 1 ] ));
return 0;
}
__PACKAGE__->meta->make_immutable;
no Moose;
1;
__END__
=pod
=head1 Name
Data::Validation::Constraints - Test data values for conformance with constraints
=head1 Version
0.9.$Revision: 174 $
=head1 Synopsis
use Data::Validation::Constraints;
%config = ( method => $method,
exception => q(Exception::Class),
%{ $self->constraints->{ $id } || {} } );
$constraint_ref = Data::Validation::Constraints->new( %config );
$constraint_ref->validate( $value );
=head1 Description
Tests a single data value for conformance with a constraint
=head1 Configuration and Environment
Uses the L<Data::Validation::Utils> L<Moose::Role>. Defines the
following attributes:
=over 3
=item error
A string containing the error message that is thrown if the validation
fails
=item max_length
Used by L</isValidLength>. The I<length> of the supplied value must be
numerically less than this
=item max_value
Used by L</isBetweenValues>.
=item min_length
Used by L</isValidLength>.
=item min_value
Used by L</isBetweenValues>.
=item required
If true then null values are not allowed regardless of what other
validation would be done
=item value
Used by the L</isEqualTo> method as the other value in the comparison
=back
=head1 Subroutines/Methods
=head2 validate
Called by L<Data::Validation>::check_field this method implements
tests for a null input value so that individual validation methods
don't have to. It calls either a built in validation method or
L</_validate> which should have been overridden in a factory
subclass. An exception is thrown if the data value is not acceptable
=head2 _validate
Should have been overridden in an external constraint subclass
=head2 isBetweenValues
Test to see if the supplied value is numerically greater than
C<< $self->min_value >> and less than C<< $self->max_value >>
=head2 isEqualTo
Test to see if the supplied value is equal to C<< $self->value >>. Calls
C<isValidNumber> on both values to determine the type of comparison
to perform
=head2 isMandatory
Null values are not allowed
=head2 isMatchingRegex
Does the supplied value match C<< $self->pattern >>?
=head2 isPrintable
Is the supplied value entirely composed of printable characters?
=head2 isSimpleText
Simple text is defined as matching the pattern '\A [a-zA-Z0-9_ \-\.]+ \z'
=head2 isValidHostname
Calls C<gethostbyname> on the supplied value
=head2 isValidIdentifier
Identifiers must match the pattern '\A [a-zA-Z_] \w* \z'
=head2 isValidInteger
Tests to see if the supplied value is an integer
=head2 isValidLength
Tests to see if the length of the supplied value is greater than
C<< $self->min_length >> and less than C<< $self->max_length >>
=head2 isValidNumber
Return true if the supplied value C<looks_like_number>
=head1 External Constraints
Each of these constraint subclasses implements the required C<_validate>
method
=head2 Date
If the C<str2time> method in the L<CatalystX::Usul::Class::Time>
module can parse the supplied value then it is deemed to be a valid
date
=head2 Email
If the C<address> method in the L<Email::Valid> module can parse the
supplied value then it is deemed to be a valid email address
=head2 Password
Currently implements a minimum password length of six characters and
that the password contain at least one non alphabetic character
=head2 Path
Screen out these characters: ; & * { } and space
=head2 Postcode
Tests to see if the supplied value matches one of the approved
patterns for a valid postcode
=head2 URL
Call the C<request> method in L<LWP::UserAgent> to test if a URL is accessible
=head1 Diagnostics
None
=head1 Dependencies
=over 3
=item L<charnames>
=item L<Data::Validation::Utils>
=item L<Moose>
=item L<Regexp::Common>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There is no POD coverage test because the subclasses docs are in here instead
The L<Data::Validation::Constraints::Date> module requires the module
L<CatalystX::Usul::Time> and this is not listed as prerequisite as it
would create a circular dependency
Please report problems to the address below.
Patches are welcome
=head1 Author
Peter Flanigan, C<< <Support at RoxSoft.co.uk> >>
=head1 License and Copyright
Copyright (c) 2013 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: