r1212@llin: dpavlin | 2007-05-20 17:39:01 +0200

 first try at implementation of delimiters validation

git-svn-id: svn+ssh://mjesec/home/dpavlin/svn/webpac2/trunk@827 07558da8-63fa-0310-ba24-9fe276d99e06

diff --git a/lib/WebPAC/Validate.pm b/lib/WebPAC/Validate.pm
index 55dc374..dafe201 100644 (file)
--- a/lib/WebPAC/Validate.pm
+++ b/lib/WebPAC/Validate.pm
@@ -18,11 +18,11 @@ WebPAC::Validate - provide simple validation for records
 
 =head1 VERSION
 
-Version 0.10
+Version 0.11
 
 =cut
 
-our $VERSION = '0.10';
+our $VERSION = '0.11';
 
 =head1 SYNOPSIS
 
@@ -52,8 +52,13 @@ Create new validation object
 
   my $validate = new WebPAC::Validate(
        path => 'conf/validate/file',
+       delimiters => [ ' : ', ' / ', ' ; ', ' , ' ],
   );
 
+Optional parametar C<delimiters> will turn on validating of delimiters. Be
+careful here, those delimiters are just stuck into regex, so they can
+contain L<perlre> regexpes.
+
 =cut
 
 sub new {
@@ -114,6 +119,11 @@ sub new {
 
        $log->info("validation uses rules from $self->{path}");
 
+       if ( $self->{delimiters} ) {
+               $self->{delimiters_regex} = '(\^[a-z0-9]|' . join('|', @{ $self->{delimiters} }) . ')';
+               $log->info("validation check delimiters with regex $self->{delimiters_regex}");
+       }
+
        $self ? return $self : return undef;
 }
 
@@ -146,6 +156,22 @@ sub validate_rec {
 
                next if (!defined($f) || $f eq '' || $f eq '000');
 
+               # first check delimiters
+               if ( my $regex = $self->{delimiters_regex} ) {
+
+                       my $template = '';
+
+                       foreach my $v (@{ $rec->{$f} }) {
+                                       warn "## v = ", dump( $v );
+                                       my $l = _pack_subfields_hash( $v, 1 );
+                                       warn "## $l [$regex]\n";
+                                       $l =~ s/$regex/$template.=$1/eg && warn "## new: $l\n";
+                                       warn "## template: $template\n";
+                                       $self->{_delimiters_templates}->{$f}->{$template}++;
+                       }
+
+               }
+
                next if (defined( $self->{dont_validate}->{$f} ));
 
                # track field usage
@@ -222,6 +248,8 @@ sub validate_rec {
                }
        }
 
+       $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );
+
        foreach my $must (sort keys %{ $self->{must_exist} }) {
                next if ($fields->{$must});
                $errors->{$must}->{missing}++;

diff --git a/t/1-validate-delimiters.t b/t/1-validate-delimiters.t
new file mode 100755 (executable)
index 0000000..8a16e4f
--- /dev/null
+++ b/t/1-validate-delimiters.t
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 4;
+use Test::Exception;
+use blib;
+
+use Data::Dump qw/dump/;
+use Cwd qw/abs_path/;
+
+BEGIN {
+use_ok( 'WebPAC::Validate' );
+}
+
+my $debug = shift @ARGV;
+
+ok(my $abs_path = abs_path($0), "abs_path");
+$abs_path =~ s#/[^/]*$#/#;
+
+ok(my $v = new WebPAC::Validate(
+       path => "$abs_path/data/validate_test",
+       delimiters => [ ' : ', ' ; ', ' / ', ' \. ' ],
+       debug => $debug,
+), "new");
+
+diag "rules = ", dump( $v->{rules} );
+
+$v->{rules} = {};
+
+sub test_v {
+       my $row = shift || die "no row?";
+
+       my $d = dump( $row );
+
+       $row->{'000'} = [ 42 ];
+
+       $v->reset_errors;
+       my $e = $v->validate_rec( $row );
+
+       diag ">> validate $d\n",dump($e) if ($debug);
+}
+
+test_v({
+       '900' => [ { 'a' => 'a : aa = aaa : a ; a', 'b' => 'b ; b ; b ; b ; a : / z . z . ' }, { 'c' => 'a : b ; c / d' } ]
+});
+
+diag dump($v->{_delimiters_templates});
+
+is_deeply( $v->{_delimiters_templates}, {
+       900 => {
+               "^a :  :  ; ^b ;  ;  ;  ;  :  .  . "            => 1,
+               "^a :  :  ; ^b ;  ;  ;  ;  :  .  . ^c :  ;  / " => 1,
+       },
+}, 'just subfields and delimiters');
+