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

=cut

our $VERSION = '0.11';

=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 => [ ' : ', ' / ', ' ; ', ' , ' ],
  );

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 {
        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}++;
                } 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 $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;
}

=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 $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 $template = '';
                                        $l =~ s/$regex/$template.=$1/eg;
#                                       warn "## template: $template\n";
                                        $self->{_delimiters_templates}->{$f}->{$template}++ if ( $template );
                        }

                }

                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";
                                        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 = ", 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 ", 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_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          ? "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);
                }
        }


        sub _reformat {
                my $l = shift;
                $l =~ s/\t/ /g;
                $l =~ s/_/ /;
                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,
  );

Options:

=over 4

=item report

Generate humanly readable report with single fields

=back

=cut

sub delimiters_templates {
        my $self = shift;

        my $args = {@_};

        my $t = $self->{_delimiters_templates};

        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" ) .
                                "\t$count\t$template\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	827	Version 0.11
22	dpavlin	514
23			=cut
24
25	dpavlin	827	our $VERSION = '0.11';
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	514	);
57
58	dpavlin	827	Optional parametar C<delimiters> will turn on validating of delimiters. Be
59			careful here, those delimiters are just stuck into regex, so they can
60			contain L<perlre> regexpes.
61
62	dpavlin	514	=cut
63
64			sub new {
65			my $class = shift;
66			my $self = {@_};
67			bless($self, $class);
68
69			my $log = $self->_get_logger();
70
71			foreach my $p (qw/path/) {
72			$log->logconfess("need $p") unless ($self->{$p});
73			}
74
75			my $v_file = read_file( $self->{path} ) \|\|
76			$log->logdie("can't open validate path $self->{path}: $!");
77
78			my $v;
79			my $curr_line = 1;
80
81			foreach my $l (split(/[\n\r]+/, $v_file)) {
82			$curr_line++;
83
84	dpavlin	516	# skip comments and whitespaces
85			next if ($l =~ /^#/ \|\| $l =~ /^\s*$/);
86
87	dpavlin	514	$l =~ s/^\s+//;
88			$l =~ s/\s+$//;
89
90			my @d = split(/\s+/, $l);
91
92	dpavlin	516	my $fld = shift @d;
93	dpavlin	514
94	dpavlin	645	if ($fld =~ s/!$//) {
95			$self->{must_exist}->{$fld}++;
96	dpavlin	677	} elsif ($fld =~ s/-$//) {
97			$self->{dont_validate}->{$fld}++;
98	dpavlin	645	}
99
100	dpavlin	516	$log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
101
102	dpavlin	514	if (@d) {
103	dpavlin	646	$v->{$fld} = [ map {
104			my $sf = $_;
105			if ( $sf =~ s/!(\*)?$/$1/ ) {
106			$self->{must_exist_sf}->{ $fld }->{ $sf }++;
107			};
108			$sf;
109			} @d ];
110	dpavlin	514	} else {
111	dpavlin	515	$v->{$fld} = 1;
112	dpavlin	514	}
113
114			}
115
116	dpavlin	652	$log->debug("current validation rules: ", dump($v));
117	dpavlin	514
118			$self->{rules} = $v;
119
120	dpavlin	516	$log->info("validation uses rules from $self->{path}");
121
122	dpavlin	827	if ( $self->{delimiters} ) {
123			$self->{delimiters_regex} = '(\^[a-z0-9]\|' . join('\|', @{ $self->{delimiters} }) . ')';
124			$log->info("validation check delimiters with regex $self->{delimiters_regex}");
125			}
126
127	dpavlin	514	$self ? return $self : return undef;
128			}
129
130	dpavlin	768	=head2 validate_rec
131	dpavlin	515
132			Validate record and return errors
133
134	dpavlin	768	my @errors = $validate->validate_rec( $rec, $rec_dump );
135	dpavlin	515
136			=cut
137
138	dpavlin	768	sub validate_rec {
139	dpavlin	515	my $self = shift;
140
141			my $log = $self->_get_logger();
142
143	dpavlin	768	my $rec = shift \|\| $log->logdie("validate_rec need record");
144	dpavlin	653	my $rec_dump = shift;
145	dpavlin	515
146			$log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
147			$log->logdie("can't find validation rules") unless (my $r = $self->{rules});
148
149	dpavlin	652	my $errors;
150	dpavlin	515
151	dpavlin	652	$log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
152	dpavlin	515
153	dpavlin	645	my $fields;
154
155	dpavlin	515	foreach my $f (keys %{ $rec }) {
156
157	dpavlin	516	next if (!defined($f) \|\| $f eq '' \|\| $f eq '000');
158	dpavlin	515
159	dpavlin	827	# first check delimiters
160			if ( my $regex = $self->{delimiters_regex} ) {
161
162			foreach my $v (@{ $rec->{$f} }) {
163			my $l = _pack_subfields_hash( $v, 1 );
164	dpavlin	828	my $template = '';
165	dpavlin	830	$l =~ s/$regex/$template.=$1/eg;
166			# warn "## template: $template\n";
167	dpavlin	828	$self->{_delimiters_templates}->{$f}->{$template}++ if ( $template );
168	dpavlin	827	}
169
170			}
171
172	dpavlin	677	next if (defined( $self->{dont_validate}->{$f} ));
173
174			# track field usage
175	dpavlin	645	$fields->{$f}++;
176
177			if ( ! defined($r->{$f}) ) {
178	dpavlin	666	$errors->{ $f }->{unexpected} = "this field is not expected";
179	dpavlin	515	next;
180			}
181
182	dpavlin	645
183	dpavlin	515	if (ref($rec->{$f}) ne 'ARRAY') {
184	dpavlin	666	$errors->{ $f }->{not_repeatable} = "probably bug in parsing input data";
185	dpavlin	515	next;
186			}
187
188			foreach my $v (@{ $rec->{$f} }) {
189			# can we have subfields?
190			if (ref($r->{$f}) eq 'ARRAY') {
191			# are values hashes? (has subfields)
192	dpavlin	652	if (! defined($v)) {
193	dpavlin	666	# $errors->{$f}->{empty} = undef;
194	dpavlin	656	# $errors->{dump} = $rec_dump if ($rec_dump);
195	dpavlin	652	} elsif (ref($v) ne 'HASH') {
196	dpavlin	666	$errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
197	dpavlin	515	next;
198			} else {
199	dpavlin	643
200			my $h = dclone( $v );
201
202	dpavlin	645	my $sf_repeatable;
203
204	dpavlin	643	delete($v->{subfields}) if (defined($v->{subfields}));
205
206	dpavlin	646	my $subfields;
207
208	dpavlin	515	foreach my $sf (keys %{ $v }) {
209	dpavlin	643
210	dpavlin	646	$subfields->{ $sf }++;
211
212	dpavlin	645	# is non-repeatable but with multiple values?
213			if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
214			if ( ref($v->{$sf}) eq 'ARRAY' ) {
215			$sf_repeatable->{$sf}++;
216			};
217			if (! first { $_ eq $sf } @{ $r->{$f} }) {
218	dpavlin	666	$errors->{ $f }->{subfield}->{extra}->{$sf}++;
219	dpavlin	645	}
220	dpavlin	515	}
221	dpavlin	643
222	dpavlin	515	}
223	dpavlin	645	if (my @r_sf = sort keys( %$sf_repeatable )) {
224
225	dpavlin	652	foreach my $sf (@r_sf) {
226	dpavlin	666	$errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
227	dpavlin	670	$errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 );
228	dpavlin	652	}
229
230	dpavlin	645	}
231	dpavlin	646
232			if ( defined( $self->{must_exist_sf}->{$f} ) ) {
233			foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
234	dpavlin	647	#warn "====> $f $sf must exist\n";
235	dpavlin	666	$errors->{$f}->{subfield}->{missing}->{$sf}++
236	dpavlin	652	unless defined( $subfields->{$sf} );
237	dpavlin	646	}
238			}
239
240	dpavlin	515	}
241			} elsif (ref($v) eq 'HASH') {
242	dpavlin	666	$errors->{$f}->{unexpected_subfields}++;
243	dpavlin	670	$errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 );
244	dpavlin	515	}
245			}
246			}
247
248	dpavlin	827	$log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );
249
250	dpavlin	645	foreach my $must (sort keys %{ $self->{must_exist} }) {
251			next if ($fields->{$must});
252	dpavlin	666	$errors->{$must}->{missing}++;
253	dpavlin	653	$errors->{dump} = $rec_dump if ($rec_dump);
254	dpavlin	645	}
255
256	dpavlin	652	if ($errors) {
257	dpavlin	671	$log->debug("errors: ", $self->report_error( $errors ) );
258	dpavlin	652
259	dpavlin	653	my $mfn = $rec->{'000'}->[0] \|\| $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
260	dpavlin	652	$self->{errors}->{$mfn} = $errors;
261			}
262
263	dpavlin	515	#$log->logcluck("return from this function is ARRAY") unless wantarray;
264
265	dpavlin	652	return $errors;
266	dpavlin	515	}
267
268	dpavlin	653	=head2 reset_errors
269
270			Clean all accumulated errors for this input
271
272			$validate->reset_errors;
273
274			=cut
275
276			sub reset_errors {
277			my $self = shift;
278			delete ($self->{errors});
279			}
280
281			=head2 all_errors
282
283			Return hash with all errors
284
285			print dump( $validate->all_errors );
286
287			=cut
288
289			sub all_errors {
290			my $self = shift;
291			return $self->{errors};
292			}
293
294	dpavlin	671	=head2 report_error
295	dpavlin	664
296	dpavlin	671	Produce nice humanly readable report of single error
297	dpavlin	664
298	dpavlin	671	print $validate->report_error( $error_hash );
299	dpavlin	664
300			=cut
301
302	dpavlin	671	sub report_error {
303	dpavlin	664	my $self = shift;
304
305	dpavlin	671	my $h = shift \|\| die "no hash?";
306
307			sub _unroll {
308	dpavlin	666	my ($self, $tree, $accumulated) = @_;
309	dpavlin	664
310	dpavlin	666	my $log = $self->_get_logger();
311
312	dpavlin	665	$log->debug("# ",
313			( $tree ? "tree: $tree " : '' ),
314			( $accumulated ? "accumulated: $accumulated " : '' ),
315			);
316	dpavlin	664
317	dpavlin	665	my $results;
318	dpavlin	664
319	dpavlin	665	if (ref($tree) ne 'HASH') {
320			return ("$accumulated\t($tree)", undef);
321	dpavlin	664	}
322
323	dpavlin	665	my $dump;
324	dpavlin	664
325	dpavlin	665	foreach my $k (sort keys %{ $tree }) {
326
327	dpavlin	664	if ($k eq 'dump') {
328	dpavlin	665	$dump = $tree->{dump};
329	dpavlin	670	# warn "## dump: ",dump($dump),"\n";
330	dpavlin	664	next;
331			}
332
333	dpavlin	665	$log->debug("current: $k");
334	dpavlin	664
335	dpavlin	671	my ($new_results, $new_dump) = $self->_unroll($tree->{$k},
336	dpavlin	665	$accumulated ? "$accumulated\t$k" : $k
337			);
338
339			$log->debug(
340			( $new_results ? "new_results: " . dump($new_results) ." " : '' ),
341			);
342
343			push @$results, $new_results if ($new_results);
344			$dump = $new_dump if ($new_dump);
345
346	dpavlin	664	}
347	dpavlin	665
348			$log->debug(
349			( $results ? "results: " . dump($results) ." " : '' ),
350			);
351
352			if ($#$results == 0) {
353			return ($results->[0], $dump);
354			} else {
355			return ($results, $dump);
356			}
357	dpavlin	664	}
358
359	dpavlin	666
360	dpavlin	671	sub _reformat {
361	dpavlin	666	my $l = shift;
362			$l =~ s/\t/ /g;
363			$l =~ s/_/ /;
364			return $l;
365			}
366
367	dpavlin	671	my $out = '';
368	dpavlin	666
369	dpavlin	671	for my $f (sort keys %{ $h }) {
370			$out .= "$f: ";
371
372			my ($r, $d) = $self->_unroll( $h->{$f} );
373			my $e;
374			if (ref($r) eq 'ARRAY') {
375			$e .= join(", ", map { _reformat( $_ ) } @$r);
376			} else {
377			$e .= _reformat( $r );
378	dpavlin	666	}
379	dpavlin	671	$e .= "\n\t$d" if ($d);
380
381			$out .= $e . "\n";
382	dpavlin	664	}
383	dpavlin	671	return $out;
384			}
385	dpavlin	664
386	dpavlin	671
387			=head2 report
388
389			Produce nice humanly readable report of errors
390
391			print $validate->report;
392
393			=cut
394
395			sub report {
396			my $self = shift;
397			my $e = $self->{errors} \|\| return;
398
399			my $out;
400			foreach my $mfn (sort { $a <=> $b } keys %$e) {
401			$out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
402			}
403
404	dpavlin	664	return $out;
405	dpavlin	671
406	dpavlin	664	}
407
408	dpavlin	832	=head2 delimiters_templates
409
410	dpavlin	834	Generate report of delimiter tamplates
411	dpavlin	832
412	dpavlin	834	my $report = $validate->delimiter_teplates(
413			report => 1,
414			);
415
416			Options:
417
418			=over 4
419
420			=item report
421
422			Generate humanly readable report with single fields
423
424			=back
425
426	dpavlin	832	=cut
427
428			sub delimiters_templates {
429			my $self = shift;
430
431	dpavlin	834	my $args = {@_};
432
433	dpavlin	832	my $t = $self->{_delimiters_templates};
434
435			my $log = $self->_get_logger;
436
437			unless ($t) {
438	dpavlin	834	$log->error("called without delimiters");
439	dpavlin	832	return;
440			}
441
442			my $out;
443
444			foreach my $f (sort { $a <=> $b } keys %$t) {
445	dpavlin	834	$out .= "$f\n" if ( $args->{report} );
446			foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
447			my $count = $t->{$f}->{$template};
448			$out .=
449			( $count ? "" : "# " ) .
450			( $args->{report} ? "" : "$f\t" ) .
451			"\t$count\t$template\n";
452	dpavlin	832	}
453			}
454
455			return $out;
456			}
457
458	dpavlin	514	=head1 AUTHOR
459
460			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
461
462			=head1 COPYRIGHT & LICENSE
463
464			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
465
466			This program is free software; you can redistribute it and/or modify it
467			under the same terms as Perl itself.
468
469			=cut
470
471			1; # End of WebPAC::Validate