/[webpac2]/trunk/lib/WebPAC/Validate.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WebPAC/Validate.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 830 by dpavlin, Wed May 23 20:03:12 2007 UTC revision 857 by dpavlin, Sun May 27 16:49:15 2007 UTC
# Line 18  WebPAC::Validate - provide simple valida Line 18  WebPAC::Validate - provide simple valida
18    
19  =head1 VERSION  =head1 VERSION
20    
21  Version 0.11  Version 0.12
22    
23  =cut  =cut
24    
25  our $VERSION = '0.11';  our $VERSION = '0.12';
26    
27  =head1 SYNOPSIS  =head1 SYNOPSIS
28    
# Line 53  Create new validation object Line 53  Create new validation object
53    my $validate = new WebPAC::Validate(    my $validate = new WebPAC::Validate(
54          path => 'conf/validate/file',          path => 'conf/validate/file',
55          delimiters => [ ' : ', ' / ', ' ; ', ' , ' ],          delimiters => [ ' : ', ' / ', ' ; ', ' , ' ],
56            delimiters_path => 'conf/validate/delimiters/file',
57    );    );
58    
59  Optional parametar C<delimiters> will turn on validating of delimiters. Be  Optional parametar C<delimiters> will turn on validating of delimiters. Be
60  careful here, those delimiters are just stuck into regex, so they can  careful here, those delimiters are just stuck into regex, so they can
61  contain L<perlre> regexpes.  contain L<perlre> regexpes.
62    
63    C<path> and C<delimiters_path> can be specified by L<read_validate_file> and
64    L<read_validate_delimiters> calls.
65    
66  =cut  =cut
67    
68  sub new {  sub new {
# Line 68  sub new { Line 72  sub new {
72    
73          my $log = $self->_get_logger();          my $log = $self->_get_logger();
74    
75          foreach my $p (qw/path/) {          $self->read_validate_file( $self->{path} ) if ( $self->{path} );
76                  $log->logconfess("need $p") unless ($self->{$p});  
77            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    
82          my $v_file = read_file( $self->{path} ) ||          $self->read_validate_delimiters_file( $self->{delimiters_path} ) if ( $self->{delimiters_path} );
83                  $log->logdie("can't open validate path $self->{path}: $!");  
84            return $self;
85    }
86    
87    
88    =head2 read_validate_file
89    
90    Specify validate rules file
91    
92      $validate->read_validate_file( 'conf/validate/file' );
93    
94    Returns number of lines in file
95    
96    =cut
97    
98    sub read_validate_file {
99            my $self = shift;
100    
101            my $path = shift || die "no path?";
102    
103            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;          my $v;
109          my $curr_line = 1;          my $curr_line = 1;
# Line 117  sub new { Line 147  sub new {
147    
148          $self->{rules} = $v;          $self->{rules} = $v;
149    
150          $log->info("validation uses rules from $self->{path}");          $log->info("validation uses rules from $path");
151    
152          if ( $self->{delimiters} ) {          return $curr_line;
153                  $self->{delimiters_regex} = '(\^[a-z0-9]|' . join('|', @{ $self->{delimiters} }) . ')';  }
                 $log->info("validation check delimiters with regex $self->{delimiters_regex}");  
         }  
154    
155          $self ? return $self : return undef;  =head2 read_validate_delimiters_file
156    
157      $validate->read_validate_delimiters_file( 'conf/validate/delimiters/file' );
158    
159    =cut
160    
161    sub read_validate_delimiters_file {
162            my $self = shift;
163    
164            my $path = shift || die "no path?";
165    
166            my $log = $self->_get_logger();
167    
168            if ( -e $path ) {
169                    $log->info("using delimiter validation rules from $path");
170                    open(my $d, $path) || $log->fatal("can't open $path: $!");
171                    while(<$d>) {
172                            chomp($d);
173                            if (/^\s*(#*)\s*(\d+)\t+(\d+)\t+(.*)$/) {
174                                    my ($comment,$field,$count,$template) = ($1,$2,$3,$4);
175                                    $self->{_validate_delimiters_templates}->{$field}->{$template} = $count unless ($comment);
176                            } else {
177                                    warn "## ignored $d\n";
178                            }
179                    }
180                    close($d);
181                    #warn "_validate_delimiters_templates = ",dump( $self->{_validate_delimiters_templates} );
182            } else {
183                    $log->warn("delimiters path $path doesn't exist, it will be created after this run");
184            }
185  }  }
186    
187  =head2 validate_rec  =head2 validate_rec
# Line 144  sub validate_rec { Line 201  sub validate_rec {
201          my $rec_dump = shift;          my $rec_dump = shift;
202    
203          $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');          $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
204          $log->logdie("can't find validation rules") unless (my $r = $self->{rules});  #       $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
205            my $r = $self->{rules};
206    
207          my $errors;          my $errors;
208    
# Line 160  sub validate_rec { Line 218  sub validate_rec {
218                  if ( my $regex = $self->{delimiters_regex} ) {                  if ( my $regex = $self->{delimiters_regex} ) {
219    
220                          foreach my $v (@{ $rec->{$f} }) {                          foreach my $v (@{ $rec->{$f} }) {
221                                          my $l = _pack_subfields_hash( $v, 1 );                                  my $l = _pack_subfields_hash( $v, 1 );
222                                          my $template = '';                                  my $subfield_dump = $l;
223                                          $l =~ s/$regex/$template.=$1/eg;                                  my $template = '';
224  #                                       warn "## template: $template\n";                                  $l =~ s/$regex/$template.=$1/eg;
225                                          $self->{_delimiters_templates}->{$f}->{$template}++ if ( $template );                                  #warn "## template: $template\n";
226    
227                                    if ( $template ) {
228                                            $self->{_delimiters_templates}->{$f}->{$template}++;
229    
230                                            if ( my $v = $self->{_validate_delimiters_templates} ) {
231                                                    if ( ! defined( $v->{$f}->{$template} ) ) {
232                                                            $errors->{$f}->{potentially_invalid_combination} = $template;
233                                                            $errors->{$f}->{dump} = $subfield_dump;
234                                                    #} else {
235                                                    #       warn "## $f $template ok\n";
236                                                    }
237                                            }
238                                    }
239                          }                          }
   
240                  }                  }
241    
242                    next unless ( $r );     # skip validation of no rules are specified
243    
244                  next if (defined( $self->{dont_validate}->{$f} ));                  next if (defined( $self->{dont_validate}->{$f} ));
245    
246                  # track field usage                  # track field usage
# Line 245  sub validate_rec { Line 317  sub validate_rec {
317                  }                  }
318          }          }
319    
320          $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );          $log->debug("_delimiters_templates = ", sub { dump( $self->{_delimiters_templates} ) } );
321    
322          foreach my $must (sort keys %{ $self->{must_exist} }) {          foreach my $must (sort keys %{ $self->{must_exist} }) {
323                  next if ($fields->{$must});                  next if ($fields->{$must});
# Line 256  sub validate_rec { Line 328  sub validate_rec {
328          if ($errors) {          if ($errors) {
329                  $log->debug("errors: ", $self->report_error( $errors ) );                  $log->debug("errors: ", $self->report_error( $errors ) );
330    
331                  my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN");                  my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", sub { dump( $rec ) }, " doesn't have MFN");
332                  $self->{errors}->{$mfn} = $errors;                  $self->{errors}->{$mfn} = $errors;
333          }          }
334    
# Line 265  sub validate_rec { Line 337  sub validate_rec {
337          return $errors;          return $errors;
338  }  }
339    
340  =head2 reset_errors  =head2 reset
341    
342    Clean all accumulated errors for this input and remember delimiter templates
343    for L<save_delimiters_templates>
344    
345  Clean all accumulated errors for this input    $validate->reset;
346    
347    $validate->reset_errors;  This function B<must> be called after each input to provide accurate statistics.
348    
349  =cut  =cut
350    
351  sub reset_errors {  sub reset {
352          my $self = shift;          my $self = shift;
353    
354            my $log = $self->_get_logger;
355    
356          delete ($self->{errors});          delete ($self->{errors});
357    
358            if ( ! $self->{_delimiters_templates} ) {
359                    $log->debug("called without _delimiters_templates?");
360                    return;
361            }
362    
363            foreach my $f ( keys %{ $self->{_delimiters_templates} } ) {
364                    foreach my $t ( keys %{ $self->{_delimiters_templates}->{$f} } ) {
365                            $self->{_accumulated_delimiters_templates}->{$f}->{$t} +=
366                                    $self->{_delimiters_templates}->{$f}->{$t};
367                    }
368            }
369            $log->debug("_accumulated_delimiters_templates = ", sub { dump( $self->{_accumulated_delimiter_templates} ) } );
370            delete ($self->{_delimiters_templates});
371  }  }
372    
373  =head2 all_errors  =head2 all_errors
# Line 326  sub report_error { Line 418  sub report_error {
418    
419                          if ($k eq 'dump') {                          if ($k eq 'dump') {
420                                  $dump = $tree->{dump};                                  $dump = $tree->{dump};
421  #                               warn "## dump: ",dump($dump),"\n";                                  #warn "## dump ",dump($dump),"\n";
422                                  next;                                  next;
423                          }                          }
424    
# Line 336  sub report_error { Line 428  sub report_error {
428                                  $accumulated ? "$accumulated\t$k" : $k                                  $accumulated ? "$accumulated\t$k" : $k
429                          );                          );
430    
431                          $log->debug(                          $log->debug( "new_results: ", sub { dump($new_results) } ) if ( $new_results );
                                 ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),  
                         );  
432    
433                          push @$results, $new_results if ($new_results);                          push @$results, $new_results if ($new_results);
434                          $dump = $new_dump if ($new_dump);                          $dump = $new_dump if ($new_dump);
435    
436                  }                  }
437    
438                  $log->debug(                  $log->debug( "results: ", sub { dump($results) } ) if ( $results );
                         ( $results              ? "results: " . dump($results) ." "     : '' ),  
                 );  
439    
440                  if ($#$results == 0) {                  if ($#$results == 0) {
441                          return ($results->[0], $dump);                          return ($results->[0], $dump);
# Line 360  sub report_error { Line 448  sub report_error {
448          sub _reformat {          sub _reformat {
449                  my $l = shift;                  my $l = shift;
450                  $l =~ s/\t/ /g;                  $l =~ s/\t/ /g;
451                  $l =~ s/_/ /;                  $l =~ s/_/ /g;
452                  return $l;                  return $l;
453          }          }
454    
# Line 405  sub report { Line 493  sub report {
493    
494  }  }
495    
496    =head2 delimiters_templates
497    
498    Generate report of delimiter tamplates
499    
500      my $report = $validate->delimiter_teplates(
501            report => 1,
502            current_input => 1,
503      );
504    
505    Options:
506    
507    =over 4
508    
509    =item report
510    
511    Generate humanly readable report with single fields
512    
513    =item current_input
514    
515    Report just current_input and not accumulated data
516    
517    =back
518    
519    =cut
520    
521    sub delimiters_templates {
522            my $self = shift;
523    
524            my $args = {@_};
525    
526            my $t = $self->{_accumulated_delimiters_templates};
527            $t = $self->{_delimiters_templates} if ( $args->{current_input} );
528    
529            my $log = $self->_get_logger;
530    
531            unless ($t) {
532                    $log->error("called without delimiters");
533                    return;
534            }
535    
536            my $out;
537    
538            foreach my $f (sort { $a <=> $b } keys %$t) {
539                    $out .= "$f\n" if ( $args->{report} );
540                    foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
541                            my $count = $t->{$f}->{$template};
542                            $out .=
543                                    ( $count ? "" : "# " ) .
544                                    ( $args->{report} ? "" : "$f" ) .
545                                    "\t$count\t$template\n";
546                    }
547            }
548    
549            return $out;
550    }
551    
552    =head2 save_delimiters_templates
553    
554    Save accumulated delimiter templates
555    
556      $validator->save_delimiters_template( '/path/to/validate/delimiters' );
557    
558    =cut
559    
560    sub save_delimiters_templates {
561            my $self = shift;
562    
563            my $path = $self->{delimiters_path};
564    
565            return unless ( $path );
566    
567            my $log = $self->_get_logger;
568    
569            if ( ! $self->{_accumulated_delimiters_templates} ) {
570                    $log->error('no _accumulated_delimiters_templates found, reset');
571                    $self->reset;
572            }
573    
574            if ( ! $self->{_delimiters_templates} ) {
575                    $log->error('found _delimiters_templates, calling reset');
576                    $self->reset;
577            }
578    
579            $path .= '.new' if ( -e $path );
580    
581            open(my $d, '>', $path) || $log->fatal("can't open $path: $!");
582            print $d $self->delimiters_templates;
583            close($d);
584    
585            $log->info("new delimiters templates saved to $path");
586    }
587    
588  =head1 AUTHOR  =head1 AUTHOR
589    
590  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.830  
changed lines
  Added in v.857
  ViewVC Help
Powered by ViewVC 1.1.26