lib/WebPAC/Validate.pm

package WebPAC::Validate;

use warnings;
use strict;

use blib;

use base 'WebPAC::Common';
use File::Slurp;
use List::Util qw/first/;
use Data::Dumper;

=head1 NAME

WebPAC::Validate - provide simple validation for records

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

This module provide a simple way to validate your file against a simple
configuration file in following format:

  # field 10 doesn't have any subfields
  10
  # same with 101
  101
  # field 200 have valid subfields a-g
  200 a b c d e f g
  # field 205 can have only subfield a
  205 a
  # while 210 can have a c or d
  210 a c d

=head1 FUNCTIONS

=head2 new

Create new validation object

  my $validate = new WebPAC::Validate(
        path => '/path/to/input/validate_file',
  );

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger();

        foreach my $p (qw/path/) {
                $log->logconfess("need $p") unless ($self->{$p});
        }

        my $v_file = read_file( $self->{path} ) ||
                $log->logdie("can't open validate path $self->{path}: $!");

        my $v;
        my $curr_line = 1;

        foreach my $l (split(/[\n\r]+/, $v_file)) {
                $curr_line++;
                # skip comments
                next if ($l =~ m/^#/);

                $l =~ s/^\s+//;
                $l =~ s/\s+$//;

                my @d = split(/\s+/, $l);

                my $fld = shift @d || $log->logdie("need field name in line $curr_line: $l");

                if (@d) {
                        $v->{$fld} = \@d;
                } else {
                        $v->{$fld} = 1;
                }

        }

        $log->debug("current validation rules: ", Dumper($v));

        $self->{rules} = $v;

        $self ? return $self : return undef;
}

=head2 validate_errors

Validate record and return errors

  my @errors = $validate->validate_errors( $rec );

=cut

sub validate_errors {
        my $self = shift;

        my $log = $self->_get_logger();

        my $rec = shift || $log->logdie("validate_errors need record");

        $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
        $log->logdie("can't find validation rules") unless (my $r = $self->{rules});

        my @errors;

        $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });

        foreach my $f (keys %{ $rec }) {

                next if (!defined($f) || $f eq '');

                if (! defined($r->{$f})) {
                        push @errors, "field '$f' shouldn't exists";
                        next;
                }

                if (ref($rec->{$f}) ne 'ARRAY') {
                        push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
                        next;
                }

                foreach my $v (@{ $rec->{$f} }) {
                        # can we have subfields?
                        if (ref($r->{$f}) eq 'ARRAY') {
                                # are values hashes? (has subfields)
                                if (ref($v) ne 'HASH') {
                                        push @errors, "$f has value without subfields: $v";
                                        next;
                                } else {
                                        foreach my $sf (keys %{ $v }) {
                                                # permited subfield?
                                                if (! first { $_ eq $sf } @{ $r->{$f} }) {
                                                        push @errors, "$f has unknown subfield: $sf";
                                                }
                                        }
                                }
                        } elsif (ref($v) eq 'HASH') {
                                push @errors, "$f has subfields which is not valid";
                        }
                }
        }

        #$log->logcluck("return from this function is ARRAY") unless wantarray;

        $log->debug("errors: ", join(", ", @errors)) if (@errors);

        return @errors;
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.

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

=cut

1; # End of WebPAC::Validate
1	dpavlin	514	package WebPAC::Validate;
2
3			use warnings;
4			use strict;
5
6			use blib;
7
8			use base 'WebPAC::Common';
9			use File::Slurp;
10	dpavlin	515	use List::Util qw/first/;
11	dpavlin	514	use Data::Dumper;
12
13			=head1 NAME
14
15			WebPAC::Validate - provide simple validation for records
16
17			=head1 VERSION
18
19			Version 0.01
20
21			=cut
22
23			our $VERSION = '0.01';
24
25			=head1 SYNOPSIS
26
27			This module provide a simple way to validate your file against a simple
28			configuration file in following format:
29
30			# field 10 doesn't have any subfields
31			10
32			# same with 101
33			101
34			# field 200 have valid subfields a-g
35			200 a b c d e f g
36			# field 205 can have only subfield a
37			205 a
38			# while 210 can have a c or d
39			210 a c d
40
41			=head1 FUNCTIONS
42
43			=head2 new
44
45			Create new validation object
46
47			my $validate = new WebPAC::Validate(
48			path => '/path/to/input/validate_file',
49			);
50
51			=cut
52
53			sub new {
54			my $class = shift;
55			my $self = {@_};
56			bless($self, $class);
57
58			my $log = $self->_get_logger();
59
60			foreach my $p (qw/path/) {
61			$log->logconfess("need $p") unless ($self->{$p});
62			}
63
64			my $v_file = read_file( $self->{path} ) \|\|
65			$log->logdie("can't open validate path $self->{path}: $!");
66
67			my $v;
68			my $curr_line = 1;
69
70			foreach my $l (split(/[\n\r]+/, $v_file)) {
71			$curr_line++;
72			# skip comments
73			next if ($l =~ m/^#/);
74
75			$l =~ s/^\s+//;
76			$l =~ s/\s+$//;
77
78			my @d = split(/\s+/, $l);
79
80			my $fld = shift @d \|\| $log->logdie("need field name in line $curr_line: $l");
81
82			if (@d) {
83	dpavlin	515	$v->{$fld} = \@d;
84	dpavlin	514	} else {
85	dpavlin	515	$v->{$fld} = 1;
86	dpavlin	514	}
87
88			}
89
90			$log->debug("current validation rules: ", Dumper($v));
91
92			$self->{rules} = $v;
93
94			$self ? return $self : return undef;
95			}
96
97	dpavlin	515	=head2 validate_errors
98
99			Validate record and return errors
100
101			my @errors = $validate->validate_errors( $rec );
102
103			=cut
104
105			sub validate_errors {
106			my $self = shift;
107
108			my $log = $self->_get_logger();
109
110			my $rec = shift \|\| $log->logdie("validate_errors need record");
111
112			$log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
113			$log->logdie("can't find validation rules") unless (my $r = $self->{rules});
114
115			my @errors;
116
117			$log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
118
119			foreach my $f (keys %{ $rec }) {
120
121			next if (!defined($f) \|\| $f eq '');
122
123			if (! defined($r->{$f})) {
124			push @errors, "field '$f' shouldn't exists";
125			next;
126			}
127
128			if (ref($rec->{$f}) ne 'ARRAY') {
129			push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
130			next;
131			}
132
133			foreach my $v (@{ $rec->{$f} }) {
134			# can we have subfields?
135			if (ref($r->{$f}) eq 'ARRAY') {
136			# are values hashes? (has subfields)
137			if (ref($v) ne 'HASH') {
138			push @errors, "$f has value without subfields: $v";
139			next;
140			} else {
141			foreach my $sf (keys %{ $v }) {
142			# permited subfield?
143			if (! first { $_ eq $sf } @{ $r->{$f} }) {
144			push @errors, "$f has unknown subfield: $sf";
145			}
146			}
147			}
148			} elsif (ref($v) eq 'HASH') {
149			push @errors, "$f has subfields which is not valid";
150			}
151			}
152			}
153
154			#$log->logcluck("return from this function is ARRAY") unless wantarray;
155
156			$log->debug("errors: ", join(", ", @errors)) if (@errors);
157
158			return @errors;
159			}
160
161	dpavlin	514	=head1 AUTHOR
162
163			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
164
165			=head1 COPYRIGHT & LICENSE
166
167			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
168
169			This program is free software; you can redistribute it and/or modify it
170			under the same terms as Perl itself.
171
172			=cut
173
174			1; # End of WebPAC::Validate