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

=head1 NAME

WebPAC::Validate - provide simple validation for records

=head1 VERSION

Version 0.07

=cut

our $VERSION = '0.07';

=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} = [ map {
                                my $sf = $_;
                                if ( $sf =~ s/!(\*)?$/$1/ ) {
                                        $self->{must_exist_sf}->{ $fld }->{ $sf }++;
                                };
                                $sf;
                        } @d ];
                } else {
                        $v->{$fld} = 1;
                }

        }

        $log->debug("current validation rules: ", dump($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, $rec_dump );

=cut

sub validate_errors {
        my $self = shift;

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

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

        $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 { dump($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}) ) {
                        $errors->{field}->{ $f }->{unexpected} = "this field is not expected";
                        next;
                }


                if (ref($rec->{$f}) ne 'ARRAY') {
                        $errors->{field}->{ $f }->{not_repeatable} = "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 (! defined($v)) {
#                                       $errors->{field}->{$f}->{empty} = undef;
#                                       $errors->{dump} = $rec_dump if ($rec_dump);
                                } elsif (ref($v) ne 'HASH') {
                                        $errors->{field}->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
                                        next;
                                } else {

                                        my $h = dclone( $v );

                                        my $sf_repeatable;

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

                                        my $subfields;

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

                                                $subfields->{ $sf }++;

                                                # 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} }) {
                                                                $errors->{field}->{ $f }->{subfield}->{extra}->{$sf}++;
                                                        }
                                                }

                                        }
                                        if (my @r_sf = sort keys( %$sf_repeatable )) {

                                                foreach my $sf (@r_sf) {
                                                        $errors->{field}->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
                                                        $errors->{field}->{$f}->{dump} =
                                                                join('', _pack_subfields_hash( $h, 1 ) );
                                                }

                                        }

                                        if ( defined( $self->{must_exist_sf}->{$f} ) ) {
                                                foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
#warn "====> $f $sf must exist\n";
                                                        $errors->{field}->{$f}->{subfield}->{missing}->{$sf}++
                                                                unless defined( $subfields->{$sf} );
                                                }
                                        }

                                }
                        } elsif (ref($v) eq 'HASH') {
                                $errors->{field}->{$f}->{unexpected_subfields}++;
                                $errors->{field}->{$f}->{dump} =
                                        join('', _pack_subfields_hash( $v, 1 ) );
                        }
                }
        }

        foreach my $must (sort keys %{ $self->{must_exist} }) {
                next if ($fields->{$must});
                $errors->{field}->{$must}->{missing}++;
                $errors->{dump} = $rec_dump if ($rec_dump);
        }

        if ($errors) {
                $log->debug("errors: ", sub { dump( $errors ) } );

                my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
                $self->{errors}->{$mfn} = $errors;
        }

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

        return $errors;
}

=head2 reset_errors

Clean all accumulated errors for this input

  $validate->reset_errors;

=cut

sub reset_errors {
        my $self = shift;
        delete ($self->{errors});
}

=head2 all_errors

Return hash with all errors

  print dump( $validate->all_errors );

=cut

sub all_errors {
        my $self = shift;
        return $self->{errors};
}

=head2 report

Produce nice humanly readable report of errors

  print $validate->report;

=cut

sub report {
        my $self = shift;

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

        sub unroll {
                my ($tree, $accumulated) = @_;

                $log->debug("# ",
                        ( $tree                 ? "tree: $tree "                                        : '' ),
                        ( $accumulated  ? "accumulated: $accumulated "          : '' ),
                );

                my $results;

                if (ref($tree) ne 'HASH') {
                        return ("$accumulated\t($tree)", undef);
                }

                my $dump;

                foreach my $k (sort keys %{ $tree }) {

                        if ($k eq 'dump') {
                                $dump = $tree->{dump};
                                warn "## dump: $dump\n";
                                next;
                        }

                        $log->debug("current: $k");

                        my ($new_results, $new_dump) = unroll($tree->{$k},
                                $accumulated ? "$accumulated\t$k" : $k
                        );

                        $log->debug(
                                ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),
                        );

                        push @$results, $new_results if ($new_results);
                        $dump = $new_dump if ($new_dump);

                }

                $log->debug(
                        ( $results              ? "results: " . dump($results) ." "     : '' ),
                );

                if ($#$results == 0) {
                        return ($results->[0], $dump);
                } else {
                        return ($results, $dump);
                }
        }

        my $out = '';
        my $e = $self->{errors} || return;

        foreach my $mfn (sort keys %$e) {
                my ($r, $d) = unroll( $e->{$mfn} );
                $out .= "MFN $mfn\n", dump($r), "\t$d\n\n";
        }

        return $out;
}

=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	652	use Data::Dump qw/dump/;
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	664	Version 0.07
22	dpavlin	514
23			=cut
24
25	dpavlin	664	our $VERSION = '0.07';
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	646	$v->{$fld} = [ map {
95			my $sf = $_;
96			if ( $sf =~ s/!(\*)?$/$1/ ) {
97			$self->{must_exist_sf}->{ $fld }->{ $sf }++;
98			};
99			$sf;
100			} @d ];
101	dpavlin	514	} else {
102	dpavlin	515	$v->{$fld} = 1;
103	dpavlin	514	}
104
105			}
106
107	dpavlin	652	$log->debug("current validation rules: ", dump($v));
108	dpavlin	514
109			$self->{rules} = $v;
110
111	dpavlin	516	$log->info("validation uses rules from $self->{path}");
112
113	dpavlin	514	$self ? return $self : return undef;
114			}
115
116	dpavlin	515	=head2 validate_errors
117
118			Validate record and return errors
119
120	dpavlin	653	my @errors = $validate->validate_errors( $rec, $rec_dump );
121	dpavlin	515
122			=cut
123
124			sub validate_errors {
125			my $self = shift;
126
127			my $log = $self->_get_logger();
128
129			my $rec = shift \|\| $log->logdie("validate_errors need record");
130	dpavlin	653	my $rec_dump = shift;
131	dpavlin	515
132			$log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
133			$log->logdie("can't find validation rules") unless (my $r = $self->{rules});
134
135	dpavlin	652	my $errors;
136	dpavlin	515
137	dpavlin	652	$log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
138	dpavlin	515
139	dpavlin	645	my $fields;
140
141	dpavlin	515	foreach my $f (keys %{ $rec }) {
142
143	dpavlin	516	next if (!defined($f) \|\| $f eq '' \|\| $f eq '000');
144	dpavlin	515
145	dpavlin	645	$fields->{$f}++;
146
147			if ( ! defined($r->{$f}) ) {
148	dpavlin	654	$errors->{field}->{ $f }->{unexpected} = "this field is not expected";
149	dpavlin	515	next;
150			}
151
152	dpavlin	645
153	dpavlin	515	if (ref($rec->{$f}) ne 'ARRAY') {
154	dpavlin	652	$errors->{field}->{ $f }->{not_repeatable} = "probably bug in parsing input data";
155	dpavlin	515	next;
156			}
157
158			foreach my $v (@{ $rec->{$f} }) {
159			# can we have subfields?
160			if (ref($r->{$f}) eq 'ARRAY') {
161			# are values hashes? (has subfields)
162	dpavlin	652	if (! defined($v)) {
163	dpavlin	656	# $errors->{field}->{$f}->{empty} = undef;
164			# $errors->{dump} = $rec_dump if ($rec_dump);
165	dpavlin	652	} elsif (ref($v) ne 'HASH') {
166	dpavlin	656	$errors->{field}->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
167	dpavlin	515	next;
168			} else {
169	dpavlin	643
170			my $h = dclone( $v );
171
172	dpavlin	645	my $sf_repeatable;
173
174	dpavlin	643	delete($v->{subfields}) if (defined($v->{subfields}));
175
176	dpavlin	646	my $subfields;
177
178	dpavlin	515	foreach my $sf (keys %{ $v }) {
179	dpavlin	643
180	dpavlin	646	$subfields->{ $sf }++;
181
182	dpavlin	645	# is non-repeatable but with multiple values?
183			if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
184			if ( ref($v->{$sf}) eq 'ARRAY' ) {
185			$sf_repeatable->{$sf}++;
186			};
187			if (! first { $_ eq $sf } @{ $r->{$f} }) {
188	dpavlin	654	$errors->{field}->{ $f }->{subfield}->{extra}->{$sf}++;
189	dpavlin	645	}
190	dpavlin	515	}
191	dpavlin	643
192	dpavlin	515	}
193	dpavlin	645	if (my @r_sf = sort keys( %$sf_repeatable )) {
194
195	dpavlin	652	foreach my $sf (@r_sf) {
196	dpavlin	656	$errors->{field}->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
197			$errors->{field}->{$f}->{dump} =
198	dpavlin	652	join('', _pack_subfields_hash( $h, 1 ) );
199			}
200
201	dpavlin	645	}
202	dpavlin	646
203			if ( defined( $self->{must_exist_sf}->{$f} ) ) {
204			foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
205	dpavlin	647	#warn "====> $f $sf must exist\n";
206	dpavlin	664	$errors->{field}->{$f}->{subfield}->{missing}->{$sf}++
207	dpavlin	652	unless defined( $subfields->{$sf} );
208	dpavlin	646	}
209			}
210
211	dpavlin	515	}
212			} elsif (ref($v) eq 'HASH') {
213	dpavlin	652	$errors->{field}->{$f}->{unexpected_subfields}++;
214	dpavlin	653	$errors->{field}->{$f}->{dump} =
215	dpavlin	652	join('', _pack_subfields_hash( $v, 1 ) );
216	dpavlin	515	}
217			}
218			}
219
220	dpavlin	645	foreach my $must (sort keys %{ $self->{must_exist} }) {
221			next if ($fields->{$must});
222	dpavlin	652	$errors->{field}->{$must}->{missing}++;
223	dpavlin	653	$errors->{dump} = $rec_dump if ($rec_dump);
224	dpavlin	645	}
225
226	dpavlin	652	if ($errors) {
227			$log->debug("errors: ", sub { dump( $errors ) } );
228
229	dpavlin	653	my $mfn = $rec->{'000'}->[0] \|\| $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
230	dpavlin	652	$self->{errors}->{$mfn} = $errors;
231			}
232
233	dpavlin	515	#$log->logcluck("return from this function is ARRAY") unless wantarray;
234
235	dpavlin	652	return $errors;
236	dpavlin	515	}
237
238	dpavlin	653	=head2 reset_errors
239
240			Clean all accumulated errors for this input
241
242			$validate->reset_errors;
243
244			=cut
245
246			sub reset_errors {
247			my $self = shift;
248			delete ($self->{errors});
249			}
250
251			=head2 all_errors
252
253			Return hash with all errors
254
255			print dump( $validate->all_errors );
256
257			=cut
258
259			sub all_errors {
260			my $self = shift;
261			return $self->{errors};
262			}
263
264	dpavlin	664	=head2 report
265
266			Produce nice humanly readable report of errors
267
268			print $validate->report;
269
270			=cut
271
272			sub report {
273			my $self = shift;
274
275	dpavlin	665	my $log = $self->_get_logger();
276
277	dpavlin	664	sub unroll {
278	dpavlin	665	my ($tree, $accumulated) = @_;
279	dpavlin	664
280	dpavlin	665	$log->debug("# ",
281			( $tree ? "tree: $tree " : '' ),
282			( $accumulated ? "accumulated: $accumulated " : '' ),
283			);
284	dpavlin	664
285	dpavlin	665	my $results;
286	dpavlin	664
287	dpavlin	665	if (ref($tree) ne 'HASH') {
288			return ("$accumulated\t($tree)", undef);
289	dpavlin	664	}
290
291	dpavlin	665	my $dump;
292	dpavlin	664
293	dpavlin	665	foreach my $k (sort keys %{ $tree }) {
294
295	dpavlin	664	if ($k eq 'dump') {
296	dpavlin	665	$dump = $tree->{dump};
297	dpavlin	664	warn "## dump: $dump\n";
298			next;
299			}
300
301	dpavlin	665	$log->debug("current: $k");
302	dpavlin	664
303	dpavlin	665	my ($new_results, $new_dump) = unroll($tree->{$k},
304			$accumulated ? "$accumulated\t$k" : $k
305			);
306
307			$log->debug(
308			( $new_results ? "new_results: " . dump($new_results) ." " : '' ),
309			);
310
311			push @$results, $new_results if ($new_results);
312			$dump = $new_dump if ($new_dump);
313
314	dpavlin	664	}
315	dpavlin	665
316			$log->debug(
317			( $results ? "results: " . dump($results) ." " : '' ),
318			);
319
320			if ($#$results == 0) {
321			return ($results->[0], $dump);
322			} else {
323			return ($results, $dump);
324			}
325	dpavlin	664	}
326
327			my $out = '';
328	dpavlin	665	my $e = $self->{errors} \|\| return;
329	dpavlin	664
330	dpavlin	665	foreach my $mfn (sort keys %$e) {
331			my ($r, $d) = unroll( $e->{$mfn} );
332			$out .= "MFN $mfn\n", dump($r), "\t$d\n\n";
333	dpavlin	664	}
334
335			return $out;
336			}
337
338	dpavlin	514	=head1 AUTHOR
339
340			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
341
342			=head1 COPYRIGHT & LICENSE
343
344			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
345
346			This program is free software; you can redistribute it and/or modify it
347			under the same terms as Perl itself.
348
349			=cut
350
351			1; # End of WebPAC::Validate