File Coverage

blib/lib/Data/RuledValidator/Util.pm

Criterion	Covered	Total	%
statement	47	50	94.0
branch	15	20	75.0
condition	7	8	87.5
subroutine	8	8	100.0
pod	0	2	0.0
total	77	88	87.5

package Data::RuledValidator::Util;

use strict;
use warnings qw/all/;
use base qw/Exporter/;

our @EXPORT = qw(NEED_ALIAS ALLOW_NO_VALUE RKEYS _arg _vand _vor);

our $VERSION = 0.02;

sub NEED_ALIAS      { 1 }
sub ALLOW_NO_VALUE  { 2 }

# '&' validation for multiple values
sub _vand{
  my ($self, $key, $c, $val, $sub) = @_;
  my $ok = 1;
  foreach my $v (@$val){
    my $_ok = 1;
    if($_ok = $sub->($self, $v) ? 1 : 0){
      push @{$self->{right}->{"${key}_$c"} ||= []},  $v;
    }else{
      push @{$self->{wrong}->{"${key}_$c"} ||= []},  $v;
    }
    $ok &= $_ok;
  }
  return $ok;
}

# '|' validation for multiple values
sub _vor{
  my ($self, $key, $c, $val, $sub) = @_;
  my $ok = 0;
  foreach my $v (@$val){
    my $_ok = 0;
    if($_ok = $sub->($self, $v) ? 1 : 0){
      push @{$self->{right}->{"${key}_$c"} ||= []},  $v;
    }else{
      push @{$self->{wrong}->{"${key}_$c"} ||= []},  $v;
    }
    $ok |= $_ok;
  }
  return $ok;
}

sub _arg{# to escape quote, use \
  shift if $_[0] eq __PACKAGE__;
  # it is refer to Perl memo()
  # http://www.din.or.jp/~ohzaki/perl.htm#CSV2Values
  my($arg) = @_;
  my @arg;
  $arg =~ s/(?:\x0D\x0A|[\x0D\x0A])?$/,/;
  return \@arg if $arg eq ',';
  while($arg){
    if($arg =~ s/^\s*('[^']*(?:\\'[^']*)*')\s*,//){
      # value quoted with ""
      $_ = $1;
      push @arg, scalar(s/^\s*'(.*)'\s*$/$1/, s/\\'/'/g, $_)
    }elsif($arg =~ s/^\s*("[^"]*(?:\\"[^"]*)*")\s*,//){
      # value quoted with ''
      $_ = $1;
      push @arg, scalar(s/^\s*"(.*)"\s*$/$1/, s/\\"/"/g, $_)
    }elsif($arg =~s/^([^,]+),//){
      $_ = $1;
      s/\s*$//g;
      push @arg, $_ unless $_ eq '';
    }else{
      warn $arg;
    }
    $arg =~s/^[,\s]*//;
  }
  return @arg;
}

1;

=head1 Name

Data::RuledValidator::Util - utilitie functions to be used Data::RuledValidator*

=head1 Description

=head1 Synopsys

=head1 Author

Ktat, [e-mail]

=head1 Copyright

Copyright 2006-2007 by Ktat

This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

See http://www.perl.com/perl/misc/Artistic.html

=cut