package Data::Compare::Type::Regex;
use 5.008_001;
use strict;
use warnings;
use Email::Valid;
use Time::Piece;
our $VERSION = '0.02';
use base 'Exporter';
our @EXPORT= qw/NOT_BLANK INT ASCII STRING DECIMAL EMAIL DATETIME DATE TIME TINYINT URL LENGTH BETWEEN/;
sub NOT_BLANK{
my $s = shift;
if (defined $s and length($s) > 0 ){
return 1;
}
!!$s;
}
sub INT{
my $s = shift;
return 1 unless $s;
$s =~ m/^\d+$|^-\d+$/;
}
sub ASCII{
my $s = shift;
return 1 unless $s;
$s =~ /^[\x21-\x7E]+$/;
}
sub STRING{
my $s = shift;
return 1 unless $s;
1;
}
sub DECIMAL{
my $s = shift;
return 1 unless $s;
$s =~ m/^\d+\.\d+$|^-\d+\.\d+$/ or INT($s);
}
sub EMAIL{
my $s = shift;
return 1 unless $s;
Email::Valid->address(-address => $s);
}
sub DATETIME{
my $s = shift;
return 1 unless $s;
eval{
Time::Piece->strptime($s , "%Y-%m-%d %H:%M:%S");
};
if($@){
eval{
Time::Piece->strptime($s , "%Y/%m/%d %H:%M:%S");
}
}
if($@){
eval{
Time::Piece->strptime($s , "%Y-%m-%d %H-%M-%S");
}
}
if($@){
eval{
Time::Piece->strptime($s , "%Y/%m/%d %H-%M-%S");
}
}
!$@
}
sub DATE{
my $s = shift;
return 1 unless $s;
eval{
Time::Piece->strptime($s , "%Y-%m-%d");
};
if($@){
eval{
Time::Piece->strptime($s , "%Y/%m/%d");
}
}
if($@){
eval{
Time::Piece->strptime($s , "%Y-%m-%d");
}
}
if($@){
eval{
Time::Piece->strptime($s , "%Y/%m/%d");
}
}
!$@
}
sub TIME{
my $s = shift;
return 1 unless $s;
$s =~ m/\d{2}-\d{2}-\d{2}|\d{2}:\d{2}:\d{2}/;
}
sub TINYINT{
my $s = shift;
return 1 unless $s;
return ($s eq "0" or $s eq "1");
}
sub LENGTH{
my ($s , $min , $max) = @_;
my $len = length($s);
if($len == 0 or $len >= $min and $len <= $max){
return 1;
}else{
return 0;
}
}
sub BETWEEN{
my ($s , $min , $max) = @_;
if($s >= $min and $s <= $max){
return 1;
}else{
return 0;
}
}
sub URL{
my ($s) = @_;
return 1 unless $s;
$s =~ m/^http:\/\/|^https:\/\//;
}
1;
__END__
=head1 NAME
Data::Compare::Type::Regex - Plugin for Data::Compare::Type
=head1 VERSION
This document describes Data::Compare::Type::Regex version 0.01.
=head1 SYNOPSIS
use Data::Compare::Type;
$class = Data::Compare::Type->new;
$class->load_plugin('Data::Compare::Type::Regex');
=head1 DESCRIPTION
This module provides some validate methods based on regex
use Test::More;
ok $class->NOT_BLANK('value');
ng $class->NOT_BLANK('');
=head1 INTERFACE
=head2 Functions
=head3 INT
# allow integer ; 10 , 0 , -10
ok $v->check(
{key => "1" },
{key => "INT"});
=head3 STRING
# allow all Strings
ok $v->check(
["111" , "abcde"],
["STRING"]);
=head3 ASCII
# allow Arabic number and alphabet and ascii symbols
ok $v->check(
["111" , 'abcde!"#$%%()'],
["ASCII"]);
# not allow multi bytes characters
ng $v->check(
["あ" , "漢字"],
["ASCII"]);
=head3 DECIMAL
# allow integer and decimals ; 10 1,0 , 0 , -10 , -1.0
ok $v->check(
["111" , "11.1" , "-11" , '0' , '-1.15'],
["DECIMAL"]);
=head3 URL
# allow ^http|^https
ok $v->check(
["http://google.com" , 'https://www.google.com/'],
["URL"]);
ng $v->check(
["git://google.com" , 'smb://www.google.com/'],
["URL"]);
=head3 EMAIL
this is base on Email::Valid;
=head3 DATETIME
# The following examples are followed.
ok $v->check([
'%Y-%m-%d %H:%M:%S',
'%Y/%m/%d %H:%M:%S',
'%Y-%m-%d %H-%M-%S',
'%Y/%m/%d %H-%M-%S',],
['DATETIME']);
=head3 DATE
# The following examples are followed.
ok $v->check([
'%Y-%m-%d',
'%Y/%m/%d'],
['DATE']);
=head3 TIME
# The following examples are followed.
ok $v->check([
'%H-%M-%S',
'%H-%M-%S'],
['TIME']);
=head3 LENGTH
# check value length
$rule = ["ASCII","NOT_BLANK" , ['LENGTH' , 1 , 8]];
ok $v->check(['a'] , $rule);
ng $v->check(['abcdefghi'] , $rule);
$rule = ["ASCII","NOT_BLANK" , ['LENGTH' , 4]];
ng $v->check(['abc'] , $rule) # false
ok $v->check(['abcd'] , $rule) # true
ng $v->check(['abcde'] , $rule) # false
=head3 BETWEEN
# check value
$rule = ["INT",['BETWEEN' , 1 , 8]];
ok $v->check([1] , $rule) # true
ng $v->check([3.1] , $rule) # false not INT
ok $v->check([5] , $rule) # true
ng $v->check([7.9] , $rule) # false not INT
ok $v->check([8] , $rule) # true
ng $v->check([9] , $rule) # false, input is over 8
ng $v->check([0] , $rule) # false, input is under 1
=head1 DEPENDENCIES
Perl 5.8.1 or later.
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 SEE ALSO
L<perl>
=head1 AUTHOR
S2 E<lt>s2otsa@hotmail.comE<gt>
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2012, S2. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut