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;
use WebPAC::Normalize qw/_pack_subfields_hash/;
use Storable qw/dclone/;

=head1 NAME

WebPAC::Validate - provide simple validation for records

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=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
  # and field e is repeatable
  200 a b c d e* f g
  # field 205 can have only subfield a
  # and must exists
  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 => 'conf/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 and whitespaces
                next if ($l =~ /^#/ || $l =~ /^\s*$/);

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

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

                my $fld = shift @d;

                if ($fld =~ s/!$//) {
                        $self->{must_exist}->{$fld}++;
                }

                $log->logdie("need field name in line $curr_line: $l") unless (defined($fld));

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

        }

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

        $self->{rules} = $v;

        $log->info("validation uses rules from $self->{path}");

        $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 });

        my $fields;

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

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

                $fields->{$f}++;

                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 {

                                        my $h = dclone( $v );

                                        my $sf_repeatable;

                                        delete($v->{subfields}) if (defined($v->{subfields}));

                                        foreach my $sf (keys %{ $v }) {

                                                # is non-repeatable but with multiple values?
                                                if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
                                                        if ( ref($v->{$sf}) eq 'ARRAY' ) {
                                                                $sf_repeatable->{$sf}++;
                                                        };
                                                        if (! first { $_ eq $sf } @{ $r->{$f} }) {
                                                                push @errors, "$f has unknown subfield: $sf";
                                                        }
                                                }

                                        }
                                        if (my @r_sf = sort keys( %$sf_repeatable )) {
                                                my $plural = $#r_sf > 0 ? 1 : 0;

                                                push @errors, "$f subfield" .
                                                ( $plural ? 's ' : ' ' ) .
                                                join(', ', @r_sf) .
                                                ( $plural ? ' are ' : ' is ' ) .
                                                'repeatable in: ' .
                                                join('', _pack_subfields_hash( $h, 1) );
                                        }
                                }
                        } elsif (ref($v) eq 'HASH') {
                                push @errors, "$f has subfields which is not valid";
                        }
                }
        }

        foreach my $must (sort keys %{ $self->{must_exist} }) {
                next if ($fields->{$must});
                push @errors,
                        "field $must should exist, but it doesn't";
        }

        #$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	dpavlin	643	use WebPAC::Normalize qw/_pack_subfields_hash/;
13			use Storable qw/dclone/;
14	dpavlin	514
15			=head1 NAME
16
17			WebPAC::Validate - provide simple validation for records
18
19			=head1 VERSION
20
21	dpavlin	645	Version 0.03
22	dpavlin	514
23			=cut
24
25	dpavlin	645	our $VERSION = '0.03';
26	dpavlin	514
27			=head1 SYNOPSIS
28
29			This module provide a simple way to validate your file against a simple
30			configuration file in following format:
31
32			# field 10 doesn't have any subfields
33			10
34			# same with 101
35			101
36			# field 200 have valid subfields a-g
37	dpavlin	645	# and field e is repeatable
38			200 a b c d e* f g
39	dpavlin	514	# field 205 can have only subfield a
40	dpavlin	645	# and must exists
41			205! a
42	dpavlin	514	# while 210 can have a c or d
43			210 a c d
44
45			=head1 FUNCTIONS
46
47			=head2 new
48
49			Create new validation object
50
51			my $validate = new WebPAC::Validate(
52	dpavlin	643	path => 'conf/validate/file',
53	dpavlin	514	);
54
55			=cut
56
57			sub new {
58			my $class = shift;
59			my $self = {@_};
60			bless($self, $class);
61
62			my $log = $self->_get_logger();
63
64			foreach my $p (qw/path/) {
65			$log->logconfess("need $p") unless ($self->{$p});
66			}
67
68			my $v_file = read_file( $self->{path} ) \|\|
69			$log->logdie("can't open validate path $self->{path}: $!");
70
71			my $v;
72			my $curr_line = 1;
73
74			foreach my $l (split(/[\n\r]+/, $v_file)) {
75			$curr_line++;
76
77	dpavlin	516	# skip comments and whitespaces
78			next if ($l =~ /^#/ \|\| $l =~ /^\s*$/);
79
80	dpavlin	514	$l =~ s/^\s+//;
81			$l =~ s/\s+$//;
82
83			my @d = split(/\s+/, $l);
84
85	dpavlin	516	my $fld = shift @d;
86	dpavlin	514
87	dpavlin	645	if ($fld =~ s/!$//) {
88			$self->{must_exist}->{$fld}++;
89			}
90
91	dpavlin	516	$log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
92
93	dpavlin	514	if (@d) {
94	dpavlin	515	$v->{$fld} = \@d;
95	dpavlin	514	} else {
96	dpavlin	515	$v->{$fld} = 1;
97	dpavlin	514	}
98
99			}
100
101			$log->debug("current validation rules: ", Dumper($v));
102
103			$self->{rules} = $v;
104
105	dpavlin	516	$log->info("validation uses rules from $self->{path}");
106
107	dpavlin	514	$self ? return $self : return undef;
108			}
109
110	dpavlin	515	=head2 validate_errors
111
112			Validate record and return errors
113
114			my @errors = $validate->validate_errors( $rec );
115
116			=cut
117
118			sub validate_errors {
119			my $self = shift;
120
121			my $log = $self->_get_logger();
122
123			my $rec = shift \|\| $log->logdie("validate_errors need record");
124
125			$log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
126			$log->logdie("can't find validation rules") unless (my $r = $self->{rules});
127
128			my @errors;
129
130			$log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
131
132	dpavlin	645	my $fields;
133
134	dpavlin	515	foreach my $f (keys %{ $rec }) {
135
136	dpavlin	516	next if (!defined($f) \|\| $f eq '' \|\| $f eq '000');
137	dpavlin	515
138	dpavlin	645	$fields->{$f}++;
139
140			if ( ! defined($r->{$f}) ) {
141	dpavlin	515	push @errors, "field '$f' shouldn't exists";
142			next;
143			}
144
145	dpavlin	645
146	dpavlin	515	if (ref($rec->{$f}) ne 'ARRAY') {
147			push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
148			next;
149			}
150
151			foreach my $v (@{ $rec->{$f} }) {
152			# can we have subfields?
153			if (ref($r->{$f}) eq 'ARRAY') {
154			# are values hashes? (has subfields)
155			if (ref($v) ne 'HASH') {
156			push @errors, "$f has value without subfields: $v";
157			next;
158			} else {
159	dpavlin	643
160			my $h = dclone( $v );
161
162	dpavlin	645	my $sf_repeatable;
163
164	dpavlin	643	delete($v->{subfields}) if (defined($v->{subfields}));
165
166	dpavlin	515	foreach my $sf (keys %{ $v }) {
167	dpavlin	643
168	dpavlin	645	# is non-repeatable but with multiple values?
169			if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
170			if ( ref($v->{$sf}) eq 'ARRAY' ) {
171			$sf_repeatable->{$sf}++;
172			};
173			if (! first { $_ eq $sf } @{ $r->{$f} }) {
174			push @errors, "$f has unknown subfield: $sf";
175			}
176	dpavlin	515	}
177	dpavlin	643
178	dpavlin	515	}
179	dpavlin	645	if (my @r_sf = sort keys( %$sf_repeatable )) {
180			my $plural = $#r_sf > 0 ? 1 : 0;
181
182			push @errors, "$f subfield" .
183			( $plural ? 's ' : ' ' ) .
184			join(', ', @r_sf) .
185			( $plural ? ' are ' : ' is ' ) .
186			'repeatable in: ' .
187			join('', _pack_subfields_hash( $h, 1) );
188			}
189	dpavlin	515	}
190			} elsif (ref($v) eq 'HASH') {
191			push @errors, "$f has subfields which is not valid";
192			}
193			}
194			}
195
196	dpavlin	645	foreach my $must (sort keys %{ $self->{must_exist} }) {
197			next if ($fields->{$must});
198			push @errors,
199			"field $must should exist, but it doesn't";
200			}
201
202	dpavlin	515	#$log->logcluck("return from this function is ARRAY") unless wantarray;
203
204			$log->debug("errors: ", join(", ", @errors)) if (@errors);
205
206			return @errors;
207			}
208
209	dpavlin	514	=head1 AUTHOR
210
211			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
212
213			=head1 COPYRIGHT & LICENSE
214
215			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
216
217			This program is free software; you can redistribute it and/or modify it
218			under the same terms as Perl itself.
219
220			=cut
221
222			1; # End of WebPAC::Validate