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.12

=cut

our $VERSION = '0.12';

=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
  # field which is ignored in validation
  999-

=head1 FUNCTIONS

=head2 new

Create new validation object

  my $validate = new WebPAC::Validate(
        path => 'conf/validate/file',
        delimiters => [ ' : ', ' / ', ' ; ', ' , ' ],
        delimiters_path => 'conf/validate/delimiters/file',
  );

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.

C<path> and C<delimiters_path> can be specified by L<read_validate_file> and
L<read_validate_delimiters> calls.

=cut

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

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

        $self->read_validate_file( $self->{path} ) if ( $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->read_validate_delimiters_file( $self->{delimiters_path} ) if ( $self->{delimiters_path} );

        return $self;
}


=head2 read_validate_file

Specify validate rules file

  $validate->read_validate_file( 'conf/validate/file' );

Returns number of lines in file

=cut

sub read_validate_file {
        my $self = shift;

        my $path = shift || die "no path?";

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

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

        my $v;
        delete( $self->{must_exist} );
        delete( $self->{must_exist_sf} );
        delete( $self->{dont_validate} );
        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}++;
                } elsif ($fld =~ s/-$//) {
                        $self->{dont_validate}->{$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 $path");

        return $curr_line;
}

=head2 read_validate_delimiters_file

  $validate->read_validate_delimiters_file( 'conf/validate/delimiters/file' );

=cut

sub read_validate_delimiters_file {
        my $self = shift;

        my $path = shift || die "no path?";

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

        delete( $self->{_validate_delimiters_templates} );
        delete( $self->{_delimiters_templates} );

        if ( -e $path ) {
                $log->info("using delimiter validation rules from $path");
                open(my $d, $path) || $log->fatal("can't open $path: $!");
                while(<$d>) {
                        chomp($d);
                        if (/^\s*(#*)\s*(\d+)\t+(\d+)\t+(.*)$/) {
                                my ($comment,$field,$count,$template) = ($1,$2,$3,$4);
                                $self->{_validate_delimiters_templates}->{$field}->{$template} = $count unless ($comment);
                        } else {
                                warn "## ignored $d\n";
                        }
                }
                close($d);
                #warn "_validate_delimiters_templates = ",dump( $self->{_validate_delimiters_templates} );
        } else {
                $log->warn("delimiters path $path doesn't exist, it will be created after this run");
        }
        $self->{delimiters_path} = $path;
}

=head2 validate_rec

Validate record and return errors

  my @errors = $validate->validate_rec( $rec, $rec_dump );

=cut

sub validate_rec {
        my $self = shift;

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

        my $rec = shift || $log->logdie("validate_rec 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 $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');

                # first check delimiters
                if ( my $regex = $self->{delimiters_regex} ) {

                        foreach my $v (@{ $rec->{$f} }) {
                                my $l = _pack_subfields_hash( $v, 1 );
                                my $subfield_dump = $l;
                                my $template = '';
                                $l =~ s/$regex/$template.=$1/eg;
                                #warn "## template: $template\n";

                                if ( $template ) {
                                        $self->{_delimiters_templates}->{$f}->{$template}++;

                                        if ( my $v = $self->{_validate_delimiters_templates} ) {
                                                if ( ! defined( $v->{$f}->{$template} ) ) {
                                                        $errors->{$f}->{potentially_invalid_combination} = $template;
                                                        $errors->{$f}->{dump} = $subfield_dump;
                                                #} else {
                                                #       warn "## $f $template ok\n";
                                                }
                                        }
                                }
                        }
                }

                next unless ( $r );     # skip validation of no rules are specified

                next if (defined( $self->{dont_validate}->{$f} ));

                # track field usage
                $fields->{$f}++;

                if ( ! defined($r->{$f}) ) {
                        $errors->{ $f }->{unexpected} = "this field is not expected";
                        next;
                }


                if (ref($rec->{$f}) ne 'ARRAY') {
                        $errors->{ $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->{$f}->{empty} = undef;
#                                       $errors->{dump} = $rec_dump if ($rec_dump);
                                } elsif (ref($v) ne 'HASH') {
                                        $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
                                        $errors->{$f}->{dump} = $v;
                                        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->{ $f }->{subfield}->{extra}->{$sf}++;
                                                        }
                                                }

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

                                                foreach my $sf (@r_sf) {
                                                        $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
                                                        $errors->{$f}->{dump} = _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->{$f}->{subfield}->{missing}->{$sf}++
                                                                unless defined( $subfields->{$sf} );
                                                }
                                        }

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

        $log->debug("_delimiters_templates = ", sub { dump( $self->{_delimiters_templates} ) } );

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

        if ($errors) {
                $log->debug("errors: ", $self->report_error( $errors ) );

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

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

        return $errors;
}

=head2 reset

Clean all accumulated errors for this input and remember delimiter templates
for L<save_delimiters_templates>

  $validate->reset;

This function B<must> be called after each input to provide accurate statistics.

=cut

sub reset {
        my $self = shift;

        my $log = $self->_get_logger;

        delete ($self->{errors});

        if ( ! $self->{_delimiters_templates} ) {
                $log->debug("called without _delimiters_templates?");
                return;
        }

        foreach my $f ( keys %{ $self->{_delimiters_templates} } ) {
                foreach my $t ( keys %{ $self->{_delimiters_templates}->{$f} } ) {
                        $self->{_accumulated_delimiters_templates}->{$f}->{$t} +=
                                $self->{_delimiters_templates}->{$f}->{$t};
                }
        }
        $log->debug("_accumulated_delimiters_templates = ", sub { dump( $self->{_accumulated_delimiters_templates} ) } );
        delete ($self->{_delimiters_templates});
}

=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_error

Produce nice humanly readable report of single error

  print $validate->report_error( $error_hash );

=cut

sub report_error {
        my $self = shift;

        my $h = shift || die "no hash?";

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

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

                $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($dump),"\n";
                                next;
                        }

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

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

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

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

                }

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

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


        sub _reformat {
                my $l = shift;
                $l =~ s/\t/ /g;
                $l =~ s/_/ /g;
                return $l;
        }

        my $out = '';

        for my $f (sort keys %{ $h }) {
                $out .= "$f: ";
                
                my ($r, $d) = $self->_unroll( $h->{$f} );
                my $e;
                if (ref($r) eq 'ARRAY') {
                        $e .= join(", ", map { _reformat( $_ ) } @$r);
                } else {
                        $e .= _reformat( $r );
                }
                $e .= "\n\t$d" if ($d);

                $out .= $e . "\n";
        }
        return $out;
}


=head2 report

Produce nice humanly readable report of errors

  print $validate->report;

=cut

sub report {
        my $self = shift;
        my $e = $self->{errors} || return;

        my $out;
        foreach my $mfn (sort { $a <=> $b } keys %$e) {
                $out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
        }

        return $out;

}

=head2 delimiters_templates

Generate report of delimiter tamplates 

  my $report = $validate->delimiter_teplates(
        report => 1,
        current_input => 1,
  );

Options:

=over 4

=item report

Generate humanly readable report with single fields

=item current_input

Report just current_input and not accumulated data

=back

=cut

sub delimiters_templates {
        my $self = shift;

        my $args = {@_};

        my $t = $self->{_accumulated_delimiters_templates};
        $t = $self->{_delimiters_templates} if ( $args->{current_input} );

        my $log = $self->_get_logger;

        unless ($t) {
                $log->error("called without delimiters");
                return;
        }

        my $out;

        foreach my $f (sort { $a <=> $b } keys %$t) {
                $out .= "$f\n" if ( $args->{report} );
                foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
                        my $count = $t->{$f}->{$template};
                        $out .= 
                                ( $count ? "" : "# " ) .
                                ( $args->{report} ? "" : "$f" ) .
                                "\t$count\t$template\n";
                }
        }

        return $out;
}

=head2 save_delimiters_templates

Save accumulated delimiter templates

  $validator->save_delimiters_template( '/path/to/validate/delimiters' );

=cut

sub save_delimiters_templates {
        my $self = shift;

        my $path = shift;
        $path ||= $self->{delimiters_path};

        my $log = $self->_get_logger;

        $log->logdie("need path") unless ( $path );


        if ( ! $self->{_accumulated_delimiters_templates} ) {
                $log->error('no _accumulated_delimiters_templates found, reset');
                $self->reset;
        }

        if ( $self->{_delimiters_templates} ) {
                $log->error('found _delimiters_templates, calling reset');
                $self->reset;
        }

        $path .= '.new' if ( -e $path );

        open(my $d, '>', $path) || $log->fatal("can't open $path: $!");
        print $d $self->delimiters_templates;
        close($d);

        $log->info("new delimiters templates saved to $path");

        return 1;
}

=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	849	Version 0.12
22	dpavlin	514
23			=cut
24
25	dpavlin	849	our $VERSION = '0.12';
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	dpavlin	677	# field which is ignored in validation
45			999-
46	dpavlin	514
47			=head1 FUNCTIONS
48
49			=head2 new
50
51			Create new validation object
52
53			my $validate = new WebPAC::Validate(
54	dpavlin	643	path => 'conf/validate/file',
55	dpavlin	827	delimiters => [ ' : ', ' / ', ' ; ', ' , ' ],
56	dpavlin	837	delimiters_path => 'conf/validate/delimiters/file',
57	dpavlin	514	);
58
59	dpavlin	827	Optional parametar C<delimiters> will turn on validating of delimiters. Be
60			careful here, those delimiters are just stuck into regex, so they can
61			contain L<perlre> regexpes.
62
63	dpavlin	857	C<path> and C<delimiters_path> can be specified by L<read_validate_file> and
64			L<read_validate_delimiters> calls.
65
66	dpavlin	514	=cut
67
68			sub new {
69			my $class = shift;
70			my $self = {@_};
71			bless($self, $class);
72
73			my $log = $self->_get_logger();
74
75	dpavlin	857	$self->read_validate_file( $self->{path} ) if ( $self->{path} );
76	dpavlin	839
77	dpavlin	857	if ( $self->{delimiters} ) {
78			$self->{delimiters_regex} = '(\^[a-z0-9]\|' . join('\|', @{ $self->{delimiters} }) . ')';
79			$log->info("validation check delimiters with regex $self->{delimiters_regex}");
80			}
81	dpavlin	514
82	dpavlin	857	$self->read_validate_delimiters_file( $self->{delimiters_path} ) if ( $self->{delimiters_path} );
83	dpavlin	514
84	dpavlin	857	return $self;
85			}
86	dpavlin	514
87
88	dpavlin	857	=head2 read_validate_file
89	dpavlin	516
90	dpavlin	857	Specify validate rules file
91	dpavlin	514
92	dpavlin	857	$validate->read_validate_file( 'conf/validate/file' );
93	dpavlin	514
94	dpavlin	857	Returns number of lines in file
95	dpavlin	514
96	dpavlin	857	=cut
97	dpavlin	645
98	dpavlin	857	sub read_validate_file {
99			my $self = shift;
100	dpavlin	516
101	dpavlin	857	my $path = shift \|\| die "no path?";
102	dpavlin	837
103	dpavlin	857	my $log = $self->_get_logger();
104
105			my $v_file = read_file( $path ) \|\|
106			$log->logdie("can't open validate path $path: $!");
107
108			my $v;
109	dpavlin	861	delete( $self->{must_exist} );
110	dpavlin	858	delete( $self->{must_exist_sf} );
111			delete( $self->{dont_validate} );
112	dpavlin	857	my $curr_line = 1;
113
114			foreach my $l (split(/[\n\r]+/, $v_file)) {
115			$curr_line++;
116
117			# skip comments and whitespaces
118			next if ($l =~ /^#/ \|\| $l =~ /^\s*$/);
119
120			$l =~ s/^\s+//;
121			$l =~ s/\s+$//;
122
123			my @d = split(/\s+/, $l);
124
125			my $fld = shift @d;
126
127			if ($fld =~ s/!$//) {
128			$self->{must_exist}->{$fld}++;
129			} elsif ($fld =~ s/-$//) {
130			$self->{dont_validate}->{$fld}++;
131	dpavlin	514	}
132
133	dpavlin	857	$log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
134	dpavlin	514
135	dpavlin	857	if (@d) {
136			$v->{$fld} = [ map {
137			my $sf = $_;
138			if ( $sf =~ s/!(\*)?$/$1/ ) {
139			$self->{must_exist_sf}->{ $fld }->{ $sf }++;
140			};
141			$sf;
142			} @d ];
143			} else {
144			$v->{$fld} = 1;
145			}
146	dpavlin	514
147	dpavlin	837	}
148	dpavlin	514
149	dpavlin	857	$log->debug("current validation rules: ", dump($v));
150	dpavlin	827
151	dpavlin	857	$self->{rules} = $v;
152
153			$log->info("validation uses rules from $path");
154
155			return $curr_line;
156			}
157
158			=head2 read_validate_delimiters_file
159
160			$validate->read_validate_delimiters_file( 'conf/validate/delimiters/file' );
161
162			=cut
163
164			sub read_validate_delimiters_file {
165			my $self = shift;
166
167			my $path = shift \|\| die "no path?";
168
169			my $log = $self->_get_logger();
170
171	dpavlin	858	delete( $self->{_validate_delimiters_templates} );
172			delete( $self->{_delimiters_templates} );
173
174	dpavlin	857	if ( -e $path ) {
175			$log->info("using delimiter validation rules from $path");
176			open(my $d, $path) \|\| $log->fatal("can't open $path: $!");
177			while(<$d>) {
178			chomp($d);
179			if (/^\s(#)\s(\d+)\t+(\d+)\t+(.)$/) {
180			my ($comment,$field,$count,$template) = ($1,$2,$3,$4);
181			$self->{_validate_delimiters_templates}->{$field}->{$template} = $count unless ($comment);
182			} else {
183			warn "## ignored $d\n";
184	dpavlin	837	}
185			}
186	dpavlin	857	close($d);
187			#warn "_validate_delimiters_templates = ",dump( $self->{_validate_delimiters_templates} );
188			} else {
189			$log->warn("delimiters path $path doesn't exist, it will be created after this run");
190	dpavlin	837	}
191	dpavlin	864	$self->{delimiters_path} = $path;
192	dpavlin	514	}
193
194	dpavlin	768	=head2 validate_rec
195	dpavlin	515
196			Validate record and return errors
197
198	dpavlin	768	my @errors = $validate->validate_rec( $rec, $rec_dump );
199	dpavlin	515
200			=cut
201
202	dpavlin	768	sub validate_rec {
203	dpavlin	515	my $self = shift;
204
205			my $log = $self->_get_logger();
206
207	dpavlin	768	my $rec = shift \|\| $log->logdie("validate_rec need record");
208	dpavlin	653	my $rec_dump = shift;
209	dpavlin	515
210			$log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
211	dpavlin	837	# $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
212			my $r = $self->{rules};
213	dpavlin	515
214	dpavlin	652	my $errors;
215	dpavlin	515
216	dpavlin	652	$log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
217	dpavlin	515
218	dpavlin	645	my $fields;
219
220	dpavlin	515	foreach my $f (keys %{ $rec }) {
221
222	dpavlin	516	next if (!defined($f) \|\| $f eq '' \|\| $f eq '000');
223	dpavlin	515
224	dpavlin	827	# first check delimiters
225			if ( my $regex = $self->{delimiters_regex} ) {
226
227			foreach my $v (@{ $rec->{$f} }) {
228	dpavlin	835	my $l = _pack_subfields_hash( $v, 1 );
229			my $subfield_dump = $l;
230			my $template = '';
231			$l =~ s/$regex/$template.=$1/eg;
232			#warn "## template: $template\n";
233
234			if ( $template ) {
235			$self->{_delimiters_templates}->{$f}->{$template}++;
236
237			if ( my $v = $self->{_validate_delimiters_templates} ) {
238	dpavlin	838	if ( ! defined( $v->{$f}->{$template} ) ) {
239	dpavlin	843	$errors->{$f}->{potentially_invalid_combination} = $template;
240	dpavlin	835	$errors->{$f}->{dump} = $subfield_dump;
241	dpavlin	838	#} else {
242			# warn "## $f $template ok\n";
243	dpavlin	835	}
244			}
245			}
246	dpavlin	827	}
247			}
248
249	dpavlin	837	next unless ( $r ); # skip validation of no rules are specified
250
251	dpavlin	677	next if (defined( $self->{dont_validate}->{$f} ));
252
253			# track field usage
254	dpavlin	645	$fields->{$f}++;
255
256			if ( ! defined($r->{$f}) ) {
257	dpavlin	666	$errors->{ $f }->{unexpected} = "this field is not expected";
258	dpavlin	515	next;
259			}
260
261	dpavlin	645
262	dpavlin	515	if (ref($rec->{$f}) ne 'ARRAY') {
263	dpavlin	666	$errors->{ $f }->{not_repeatable} = "probably bug in parsing input data";
264	dpavlin	515	next;
265			}
266
267			foreach my $v (@{ $rec->{$f} }) {
268			# can we have subfields?
269			if (ref($r->{$f}) eq 'ARRAY') {
270			# are values hashes? (has subfields)
271	dpavlin	652	if (! defined($v)) {
272	dpavlin	666	# $errors->{$f}->{empty} = undef;
273	dpavlin	656	# $errors->{dump} = $rec_dump if ($rec_dump);
274	dpavlin	652	} elsif (ref($v) ne 'HASH') {
275	dpavlin	666	$errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
276	dpavlin	875	$errors->{$f}->{dump} = $v;
277	dpavlin	515	next;
278			} else {
279	dpavlin	643
280			my $h = dclone( $v );
281
282	dpavlin	645	my $sf_repeatable;
283
284	dpavlin	643	delete($v->{subfields}) if (defined($v->{subfields}));
285
286	dpavlin	646	my $subfields;
287
288	dpavlin	515	foreach my $sf (keys %{ $v }) {
289	dpavlin	643
290	dpavlin	646	$subfields->{ $sf }++;
291
292	dpavlin	645	# is non-repeatable but with multiple values?
293			if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
294			if ( ref($v->{$sf}) eq 'ARRAY' ) {
295			$sf_repeatable->{$sf}++;
296			};
297			if (! first { $_ eq $sf } @{ $r->{$f} }) {
298	dpavlin	666	$errors->{ $f }->{subfield}->{extra}->{$sf}++;
299	dpavlin	645	}
300	dpavlin	515	}
301	dpavlin	643
302	dpavlin	515	}
303	dpavlin	645	if (my @r_sf = sort keys( %$sf_repeatable )) {
304
305	dpavlin	652	foreach my $sf (@r_sf) {
306	dpavlin	666	$errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
307	dpavlin	670	$errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 );
308	dpavlin	652	}
309
310	dpavlin	645	}
311	dpavlin	646
312			if ( defined( $self->{must_exist_sf}->{$f} ) ) {
313			foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
314	dpavlin	647	#warn "====> $f $sf must exist\n";
315	dpavlin	666	$errors->{$f}->{subfield}->{missing}->{$sf}++
316	dpavlin	652	unless defined( $subfields->{$sf} );
317	dpavlin	646	}
318			}
319
320	dpavlin	515	}
321			} elsif (ref($v) eq 'HASH') {
322	dpavlin	666	$errors->{$f}->{unexpected_subfields}++;
323	dpavlin	670	$errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 );
324	dpavlin	515	}
325			}
326			}
327
328	dpavlin	852	$log->debug("_delimiters_templates = ", sub { dump( $self->{_delimiters_templates} ) } );
329	dpavlin	827
330	dpavlin	645	foreach my $must (sort keys %{ $self->{must_exist} }) {
331			next if ($fields->{$must});
332	dpavlin	666	$errors->{$must}->{missing}++;
333	dpavlin	653	$errors->{dump} = $rec_dump if ($rec_dump);
334	dpavlin	645	}
335
336	dpavlin	652	if ($errors) {
337	dpavlin	671	$log->debug("errors: ", $self->report_error( $errors ) );
338	dpavlin	652
339	dpavlin	852	my $mfn = $rec->{'000'}->[0] \|\| $log->logconfess("record ", sub { dump( $rec ) }, " doesn't have MFN");
340	dpavlin	652	$self->{errors}->{$mfn} = $errors;
341			}
342
343	dpavlin	515	#$log->logcluck("return from this function is ARRAY") unless wantarray;
344
345	dpavlin	652	return $errors;
346	dpavlin	515	}
347
348	dpavlin	849	=head2 reset
349	dpavlin	653
350	dpavlin	849	Clean all accumulated errors for this input and remember delimiter templates
351			for L<save_delimiters_templates>
352	dpavlin	653
353	dpavlin	849	$validate->reset;
354	dpavlin	653
355	dpavlin	849	This function B<must> be called after each input to provide accurate statistics.
356
357	dpavlin	653	=cut
358
359	dpavlin	849	sub reset {
360	dpavlin	653	my $self = shift;
361	dpavlin	849
362			my $log = $self->_get_logger;
363
364	dpavlin	653	delete ($self->{errors});
365	dpavlin	849
366			if ( ! $self->{_delimiters_templates} ) {
367			$log->debug("called without _delimiters_templates?");
368			return;
369			}
370
371			foreach my $f ( keys %{ $self->{_delimiters_templates} } ) {
372			foreach my $t ( keys %{ $self->{_delimiters_templates}->{$f} } ) {
373			$self->{_accumulated_delimiters_templates}->{$f}->{$t} +=
374			$self->{_delimiters_templates}->{$f}->{$t};
375			}
376			}
377	dpavlin	864	$log->debug("_accumulated_delimiters_templates = ", sub { dump( $self->{_accumulated_delimiters_templates} ) } );
378	dpavlin	849	delete ($self->{_delimiters_templates});
379	dpavlin	653	}
380
381			=head2 all_errors
382
383			Return hash with all errors
384
385			print dump( $validate->all_errors );
386
387			=cut
388
389			sub all_errors {
390			my $self = shift;
391			return $self->{errors};
392			}
393
394	dpavlin	671	=head2 report_error
395	dpavlin	664
396	dpavlin	671	Produce nice humanly readable report of single error
397	dpavlin	664
398	dpavlin	671	print $validate->report_error( $error_hash );
399	dpavlin	664
400			=cut
401
402	dpavlin	671	sub report_error {
403	dpavlin	664	my $self = shift;
404
405	dpavlin	671	my $h = shift \|\| die "no hash?";
406
407			sub _unroll {
408	dpavlin	666	my ($self, $tree, $accumulated) = @_;
409	dpavlin	664
410	dpavlin	666	my $log = $self->_get_logger();
411
412	dpavlin	665	$log->debug("# ",
413			( $tree ? "tree: $tree " : '' ),
414			( $accumulated ? "accumulated: $accumulated " : '' ),
415			);
416	dpavlin	664
417	dpavlin	665	my $results;
418	dpavlin	664
419	dpavlin	665	if (ref($tree) ne 'HASH') {
420			return ("$accumulated\t($tree)", undef);
421	dpavlin	664	}
422
423	dpavlin	665	my $dump;
424	dpavlin	664
425	dpavlin	665	foreach my $k (sort keys %{ $tree }) {
426
427	dpavlin	664	if ($k eq 'dump') {
428	dpavlin	665	$dump = $tree->{dump};
429	dpavlin	835	#warn "## dump ",dump($dump),"\n";
430	dpavlin	664	next;
431			}
432
433	dpavlin	665	$log->debug("current: $k");
434	dpavlin	664
435	dpavlin	671	my ($new_results, $new_dump) = $self->_unroll($tree->{$k},
436	dpavlin	665	$accumulated ? "$accumulated\t$k" : $k
437			);
438
439	dpavlin	852	$log->debug( "new_results: ", sub { dump($new_results) } ) if ( $new_results );
440	dpavlin	665
441			push @$results, $new_results if ($new_results);
442			$dump = $new_dump if ($new_dump);
443
444	dpavlin	664	}
445	dpavlin	665
446	dpavlin	852	$log->debug( "results: ", sub { dump($results) } ) if ( $results );
447	dpavlin	665
448			if ($#$results == 0) {
449			return ($results->[0], $dump);
450			} else {
451			return ($results, $dump);
452			}
453	dpavlin	664	}
454
455	dpavlin	666
456	dpavlin	671	sub _reformat {
457	dpavlin	666	my $l = shift;
458			$l =~ s/\t/ /g;
459	dpavlin	835	$l =~ s/_/ /g;
460	dpavlin	666	return $l;
461			}
462
463	dpavlin	671	my $out = '';
464	dpavlin	666
465	dpavlin	671	for my $f (sort keys %{ $h }) {
466			$out .= "$f: ";
467
468			my ($r, $d) = $self->_unroll( $h->{$f} );
469			my $e;
470			if (ref($r) eq 'ARRAY') {
471			$e .= join(", ", map { _reformat( $_ ) } @$r);
472			} else {
473			$e .= _reformat( $r );
474	dpavlin	666	}
475	dpavlin	671	$e .= "\n\t$d" if ($d);
476
477			$out .= $e . "\n";
478	dpavlin	664	}
479	dpavlin	671	return $out;
480			}
481	dpavlin	664
482	dpavlin	671
483			=head2 report
484
485			Produce nice humanly readable report of errors
486
487			print $validate->report;
488
489			=cut
490
491			sub report {
492			my $self = shift;
493			my $e = $self->{errors} \|\| return;
494
495			my $out;
496			foreach my $mfn (sort { $a <=> $b } keys %$e) {
497			$out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
498			}
499
500	dpavlin	664	return $out;
501	dpavlin	671
502	dpavlin	664	}
503
504	dpavlin	832	=head2 delimiters_templates
505
506	dpavlin	834	Generate report of delimiter tamplates
507	dpavlin	832
508	dpavlin	834	my $report = $validate->delimiter_teplates(
509			report => 1,
510	dpavlin	851	current_input => 1,
511	dpavlin	834	);
512
513			Options:
514
515			=over 4
516
517			=item report
518
519			Generate humanly readable report with single fields
520
521	dpavlin	851	=item current_input
522	dpavlin	849
523	dpavlin	851	Report just current_input and not accumulated data
524	dpavlin	849
525	dpavlin	834	=back
526
527	dpavlin	832	=cut
528
529			sub delimiters_templates {
530			my $self = shift;
531
532	dpavlin	834	my $args = {@_};
533
534	dpavlin	851	my $t = $self->{_accumulated_delimiters_templates};
535			$t = $self->{_delimiters_templates} if ( $args->{current_input} );
536	dpavlin	832
537			my $log = $self->_get_logger;
538
539			unless ($t) {
540	dpavlin	834	$log->error("called without delimiters");
541	dpavlin	832	return;
542			}
543
544			my $out;
545
546			foreach my $f (sort { $a <=> $b } keys %$t) {
547	dpavlin	834	$out .= "$f\n" if ( $args->{report} );
548			foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
549			my $count = $t->{$f}->{$template};
550			$out .=
551			( $count ? "" : "# " ) .
552	dpavlin	836	( $args->{report} ? "" : "$f" ) .
553	dpavlin	834	"\t$count\t$template\n";
554	dpavlin	832	}
555			}
556
557			return $out;
558			}
559
560	dpavlin	837	=head2 save_delimiters_templates
561
562	dpavlin	849	Save accumulated delimiter templates
563
564			$validator->save_delimiters_template( '/path/to/validate/delimiters' );
565
566	dpavlin	837	=cut
567
568			sub save_delimiters_templates {
569			my $self = shift;
570
571	dpavlin	864	my $path = shift;
572			$path \|\|= $self->{delimiters_path};
573	dpavlin	837
574			my $log = $self->_get_logger;
575
576	dpavlin	864	$log->logdie("need path") unless ( $path );
577
578
579	dpavlin	849	if ( ! $self->{_accumulated_delimiters_templates} ) {
580			$log->error('no _accumulated_delimiters_templates found, reset');
581			$self->reset;
582			}
583
584	dpavlin	864	if ( $self->{_delimiters_templates} ) {
585	dpavlin	849	$log->error('found _delimiters_templates, calling reset');
586			$self->reset;
587			}
588
589	dpavlin	840	$path .= '.new' if ( -e $path );
590
591	dpavlin	837	open(my $d, '>', $path) \|\| $log->fatal("can't open $path: $!");
592	dpavlin	851	print $d $self->delimiters_templates;
593	dpavlin	837	close($d);
594
595			$log->info("new delimiters templates saved to $path");
596	dpavlin	949
597			return 1;
598	dpavlin	837	}
599
600	dpavlin	514	=head1 AUTHOR
601
602			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
603
604			=head1 COPYRIGHT & LICENSE
605
606			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
607
608			This program is free software; you can redistribute it and/or modify it
609			under the same terms as Perl itself.
610
611			=cut
612
613			1; # End of WebPAC::Validate