/[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 834 by dpavlin, Thu May 24 10:53:48 2007 UTC revision 858 by dpavlin, Sun May 27 17:09:47 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            delete( $self->{must_exists} );
110            delete( $self->{must_exist_sf} );
111            delete( $self->{dont_validate} );
112          my $curr_line = 1;          my $curr_line = 1;
113    
114          foreach my $l (split(/[\n\r]+/, $v_file)) {          foreach my $l (split(/[\n\r]+/, $v_file)) {
# Line 117  sub new { Line 150  sub new {
150    
151          $self->{rules} = $v;          $self->{rules} = $v;
152    
153          $log->info("validation uses rules from $self->{path}");          $log->info("validation uses rules from $path");
154    
155          if ( $self->{delimiters} ) {          return $curr_line;
156                  $self->{delimiters_regex} = '(\^[a-z0-9]|' . join('|', @{ $self->{delimiters} }) . ')';  }
157                  $log->info("validation check delimiters with regex $self->{delimiters_regex}");  
158          }  =head2 read_validate_delimiters_file
159    
160      $validate->read_validate_delimiters_file( 'conf/validate/delimiters/file' );
161    
162    =cut
163    
164          $self ? return $self : return undef;  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            delete( $self->{_validate_delimiters_templates} );
172            delete( $self->{_delimiters_templates} );
173    
174            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                            }
185                    }
186                    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            }
191  }  }
192    
193  =head2 validate_rec  =head2 validate_rec
# Line 144  sub validate_rec { Line 207  sub validate_rec {
207          my $rec_dump = shift;          my $rec_dump = shift;
208    
209          $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');          $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
210          $log->logdie("can't find validation rules") unless (my $r = $self->{rules});  #       $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
211            my $r = $self->{rules};
212    
213          my $errors;          my $errors;
214    
# Line 160  sub validate_rec { Line 224  sub validate_rec {
224                  if ( my $regex = $self->{delimiters_regex} ) {                  if ( my $regex = $self->{delimiters_regex} ) {
225    
226                          foreach my $v (@{ $rec->{$f} }) {                          foreach my $v (@{ $rec->{$f} }) {
227                                          my $l = _pack_subfields_hash( $v, 1 );                                  my $l = _pack_subfields_hash( $v, 1 );
228                                          my $template = '';                                  my $subfield_dump = $l;
229                                          $l =~ s/$regex/$template.=$1/eg;                                  my $template = '';
230  #                                       warn "## template: $template\n";                                  $l =~ s/$regex/$template.=$1/eg;
231                                          $self->{_delimiters_templates}->{$f}->{$template}++ if ( $template );                                  #warn "## template: $template\n";
232    
233                                    if ( $template ) {
234                                            $self->{_delimiters_templates}->{$f}->{$template}++;
235    
236                                            if ( my $v = $self->{_validate_delimiters_templates} ) {
237                                                    if ( ! defined( $v->{$f}->{$template} ) ) {
238                                                            $errors->{$f}->{potentially_invalid_combination} = $template;
239                                                            $errors->{$f}->{dump} = $subfield_dump;
240                                                    #} else {
241                                                    #       warn "## $f $template ok\n";
242                                                    }
243                                            }
244                                    }
245                          }                          }
   
246                  }                  }
247    
248                    next unless ( $r );     # skip validation of no rules are specified
249    
250                  next if (defined( $self->{dont_validate}->{$f} ));                  next if (defined( $self->{dont_validate}->{$f} ));
251    
252                  # track field usage                  # track field usage
# Line 245  sub validate_rec { Line 323  sub validate_rec {
323                  }                  }
324          }          }
325    
326          $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );          $log->debug("_delimiters_templates = ", sub { dump( $self->{_delimiters_templates} ) } );
327    
328          foreach my $must (sort keys %{ $self->{must_exist} }) {          foreach my $must (sort keys %{ $self->{must_exist} }) {
329                  next if ($fields->{$must});                  next if ($fields->{$must});
# Line 256  sub validate_rec { Line 334  sub validate_rec {
334          if ($errors) {          if ($errors) {
335                  $log->debug("errors: ", $self->report_error( $errors ) );                  $log->debug("errors: ", $self->report_error( $errors ) );
336    
337                  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");
338                  $self->{errors}->{$mfn} = $errors;                  $self->{errors}->{$mfn} = $errors;
339          }          }
340    
# Line 265  sub validate_rec { Line 343  sub validate_rec {
343          return $errors;          return $errors;
344  }  }
345    
346  =head2 reset_errors  =head2 reset
347    
348  Clean all accumulated errors for this input  Clean all accumulated errors for this input and remember delimiter templates
349    for L<save_delimiters_templates>
350    
351    $validate->reset_errors;    $validate->reset;
352    
353    This function B<must> be called after each input to provide accurate statistics.
354    
355  =cut  =cut
356    
357  sub reset_errors {  sub reset {
358          my $self = shift;          my $self = shift;
359    
360            my $log = $self->_get_logger;
361    
362          delete ($self->{errors});          delete ($self->{errors});
363    
364            if ( ! $self->{_delimiters_templates} ) {
365                    $log->debug("called without _delimiters_templates?");
366                    return;
367            }
368    
369            foreach my $f ( keys %{ $self->{_delimiters_templates} } ) {
370                    foreach my $t ( keys %{ $self->{_delimiters_templates}->{$f} } ) {
371                            $self->{_accumulated_delimiters_templates}->{$f}->{$t} +=
372                                    $self->{_delimiters_templates}->{$f}->{$t};
373                    }
374            }
375            $log->debug("_accumulated_delimiters_templates = ", sub { dump( $self->{_accumulated_delimiter_templates} ) } );
376            delete ($self->{_delimiters_templates});
377  }  }
378    
379  =head2 all_errors  =head2 all_errors
# Line 326  sub report_error { Line 424  sub report_error {
424    
425                          if ($k eq 'dump') {                          if ($k eq 'dump') {
426                                  $dump = $tree->{dump};                                  $dump = $tree->{dump};
427  #                               warn "## dump: ",dump($dump),"\n";                                  #warn "## dump ",dump($dump),"\n";
428                                  next;                                  next;
429                          }                          }
430    
# Line 336  sub report_error { Line 434  sub report_error {
434                                  $accumulated ? "$accumulated\t$k" : $k                                  $accumulated ? "$accumulated\t$k" : $k
435                          );                          );
436    
437                          $log->debug(                          $log->debug( "new_results: ", sub { dump($new_results) } ) if ( $new_results );
                                 ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),  
                         );  
438    
439                          push @$results, $new_results if ($new_results);                          push @$results, $new_results if ($new_results);
440                          $dump = $new_dump if ($new_dump);                          $dump = $new_dump if ($new_dump);
441    
442                  }                  }
443    
444                  $log->debug(                  $log->debug( "results: ", sub { dump($results) } ) if ( $results );
                         ( $results              ? "results: " . dump($results) ." "     : '' ),  
                 );  
445    
446                  if ($#$results == 0) {                  if ($#$results == 0) {
447                          return ($results->[0], $dump);                          return ($results->[0], $dump);
# Line 360  sub report_error { Line 454  sub report_error {
454          sub _reformat {          sub _reformat {
455                  my $l = shift;                  my $l = shift;
456                  $l =~ s/\t/ /g;                  $l =~ s/\t/ /g;
457                  $l =~ s/_/ /;                  $l =~ s/_/ /g;
458                  return $l;                  return $l;
459          }          }
460    
# Line 411  Generate report of delimiter tamplates Line 505  Generate report of delimiter tamplates
505    
506    my $report = $validate->delimiter_teplates(    my $report = $validate->delimiter_teplates(
507          report => 1,          report => 1,
508            current_input => 1,
509    );    );
510    
511  Options:  Options:
# Line 421  Options: Line 516  Options:
516    
517  Generate humanly readable report with single fields  Generate humanly readable report with single fields
518    
519    =item current_input
520    
521    Report just current_input and not accumulated data
522    
523  =back  =back
524    
525  =cut  =cut
# Line 430  sub delimiters_templates { Line 529  sub delimiters_templates {
529    
530          my $args = {@_};          my $args = {@_};
531    
532          my $t = $self->{_delimiters_templates};          my $t = $self->{_accumulated_delimiters_templates};
533            $t = $self->{_delimiters_templates} if ( $args->{current_input} );
534    
535          my $log = $self->_get_logger;          my $log = $self->_get_logger;
536    
# Line 447  sub delimiters_templates { Line 547  sub delimiters_templates {
547                          my $count = $t->{$f}->{$template};                          my $count = $t->{$f}->{$template};
548                          $out .=                          $out .=
549                                  ( $count ? "" : "# " ) .                                  ( $count ? "" : "# " ) .
550                                  ( $args->{report} ? "" : "$f\t" ) .                                  ( $args->{report} ? "" : "$f" ) .
551                                  "\t$count\t$template\n";                                  "\t$count\t$template\n";
552                  }                  }
553          }          }
# Line 455  sub delimiters_templates { Line 555  sub delimiters_templates {
555          return $out;          return $out;
556  }  }
557    
558    =head2 save_delimiters_templates
559    
560    Save accumulated delimiter templates
561    
562      $validator->save_delimiters_template( '/path/to/validate/delimiters' );
563    
564    =cut
565    
566    sub save_delimiters_templates {
567            my $self = shift;
568    
569            my $path = $self->{delimiters_path};
570    
571            return unless ( $path );
572    
573            my $log = $self->_get_logger;
574    
575            if ( ! $self->{_accumulated_delimiters_templates} ) {
576                    $log->error('no _accumulated_delimiters_templates found, reset');
577                    $self->reset;
578            }
579    
580            if ( ! $self->{_delimiters_templates} ) {
581                    $log->error('found _delimiters_templates, calling reset');
582                    $self->reset;
583            }
584    
585            $path .= '.new' if ( -e $path );
586    
587            open(my $d, '>', $path) || $log->fatal("can't open $path: $!");
588            print $d $self->delimiters_templates;
589            close($d);
590    
591            $log->info("new delimiters templates saved to $path");
592    }
593    
594  =head1 AUTHOR  =head1 AUTHOR
595    
596  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.834  
changed lines
  Added in v.858
  ViewVC Help
Powered by ViewVC 1.1.26