/[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 832 by dpavlin, Wed May 23 20:03:16 2007 UTC revision 864 by dpavlin, Sun May 27 22:24:30 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_exist} );
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} }) . ')';  }
                 $log->info("validation check delimiters with regex $self->{delimiters_regex}");  
         }  
157    
158          $self ? return $self : return undef;  =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            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            $self->{delimiters_path} = $path;
192  }  }
193    
194  =head2 validate_rec  =head2 validate_rec
# Line 144  sub validate_rec { Line 208  sub validate_rec {
208          my $rec_dump = shift;          my $rec_dump = shift;
209    
210          $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');          $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
211          $log->logdie("can't find validation rules") unless (my $r = $self->{rules});  #       $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
212            my $r = $self->{rules};
213    
214          my $errors;          my $errors;
215    
# Line 160  sub validate_rec { Line 225  sub validate_rec {
225                  if ( my $regex = $self->{delimiters_regex} ) {                  if ( my $regex = $self->{delimiters_regex} ) {
226    
227                          foreach my $v (@{ $rec->{$f} }) {                          foreach my $v (@{ $rec->{$f} }) {
228                                          my $l = _pack_subfields_hash( $v, 1 );                                  my $l = _pack_subfields_hash( $v, 1 );
229                                          my $template = '';                                  my $subfield_dump = $l;
230                                          $l =~ s/$regex/$template.=$1/eg;                                  my $template = '';
231  #                                       warn "## template: $template\n";                                  $l =~ s/$regex/$template.=$1/eg;
232                                          $self->{_delimiters_templates}->{$f}->{$template}++ if ( $template );                                  #warn "## template: $template\n";
233    
234                                    if ( $template ) {
235                                            $self->{_delimiters_templates}->{$f}->{$template}++;
236    
237                                            if ( my $v = $self->{_validate_delimiters_templates} ) {
238                                                    if ( ! defined( $v->{$f}->{$template} ) ) {
239                                                            $errors->{$f}->{potentially_invalid_combination} = $template;
240                                                            $errors->{$f}->{dump} = $subfield_dump;
241                                                    #} else {
242                                                    #       warn "## $f $template ok\n";
243                                                    }
244                                            }
245                                    }
246                          }                          }
   
247                  }                  }
248    
249                    next unless ( $r );     # skip validation of no rules are specified
250    
251                  next if (defined( $self->{dont_validate}->{$f} ));                  next if (defined( $self->{dont_validate}->{$f} ));
252    
253                  # track field usage                  # track field usage
# Line 245  sub validate_rec { Line 324  sub validate_rec {
324                  }                  }
325          }          }
326    
327          $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );          $log->debug("_delimiters_templates = ", sub { dump( $self->{_delimiters_templates} ) } );
328    
329          foreach my $must (sort keys %{ $self->{must_exist} }) {          foreach my $must (sort keys %{ $self->{must_exist} }) {
330                  next if ($fields->{$must});                  next if ($fields->{$must});
# Line 256  sub validate_rec { Line 335  sub validate_rec {
335          if ($errors) {          if ($errors) {
336                  $log->debug("errors: ", $self->report_error( $errors ) );                  $log->debug("errors: ", $self->report_error( $errors ) );
337    
338                  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");
339                  $self->{errors}->{$mfn} = $errors;                  $self->{errors}->{$mfn} = $errors;
340          }          }
341    
# Line 265  sub validate_rec { Line 344  sub validate_rec {
344          return $errors;          return $errors;
345  }  }
346    
347  =head2 reset_errors  =head2 reset
348    
349  Clean all accumulated errors for this input  Clean all accumulated errors for this input and remember delimiter templates
350    for L<save_delimiters_templates>
351    
352    $validate->reset_errors;    $validate->reset;
353    
354    This function B<must> be called after each input to provide accurate statistics.
355    
356  =cut  =cut
357    
358  sub reset_errors {  sub reset {
359          my $self = shift;          my $self = shift;
360    
361            my $log = $self->_get_logger;
362    
363          delete ($self->{errors});          delete ($self->{errors});
364    
365            if ( ! $self->{_delimiters_templates} ) {
366                    $log->debug("called without _delimiters_templates?");
367                    return;
368            }
369    
370            foreach my $f ( keys %{ $self->{_delimiters_templates} } ) {
371                    foreach my $t ( keys %{ $self->{_delimiters_templates}->{$f} } ) {
372                            $self->{_accumulated_delimiters_templates}->{$f}->{$t} +=
373                                    $self->{_delimiters_templates}->{$f}->{$t};
374                    }
375            }
376            $log->debug("_accumulated_delimiters_templates = ", sub { dump( $self->{_accumulated_delimiters_templates} ) } );
377            delete ($self->{_delimiters_templates});
378  }  }
379    
380  =head2 all_errors  =head2 all_errors
# Line 326  sub report_error { Line 425  sub report_error {
425    
426                          if ($k eq 'dump') {                          if ($k eq 'dump') {
427                                  $dump = $tree->{dump};                                  $dump = $tree->{dump};
428  #                               warn "## dump: ",dump($dump),"\n";                                  #warn "## dump ",dump($dump),"\n";
429                                  next;                                  next;
430                          }                          }
431    
# Line 336  sub report_error { Line 435  sub report_error {
435                                  $accumulated ? "$accumulated\t$k" : $k                                  $accumulated ? "$accumulated\t$k" : $k
436                          );                          );
437    
438                          $log->debug(                          $log->debug( "new_results: ", sub { dump($new_results) } ) if ( $new_results );
                                 ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),  
                         );  
439    
440                          push @$results, $new_results if ($new_results);                          push @$results, $new_results if ($new_results);
441                          $dump = $new_dump if ($new_dump);                          $dump = $new_dump if ($new_dump);
442    
443                  }                  }
444    
445                  $log->debug(                  $log->debug( "results: ", sub { dump($results) } ) if ( $results );
                         ( $results              ? "results: " . dump($results) ." "     : '' ),  
                 );  
446    
447                  if ($#$results == 0) {                  if ($#$results == 0) {
448                          return ($results->[0], $dump);                          return ($results->[0], $dump);
# Line 360  sub report_error { Line 455  sub report_error {
455          sub _reformat {          sub _reformat {
456                  my $l = shift;                  my $l = shift;
457                  $l =~ s/\t/ /g;                  $l =~ s/\t/ /g;
458                  $l =~ s/_/ /;                  $l =~ s/_/ /g;
459                  return $l;                  return $l;
460          }          }
461    
# Line 407  sub report { Line 502  sub report {
502    
503  =head2 delimiters_templates  =head2 delimiters_templates
504    
505    Generate report of delimiter tamplates
506    
507      my $report = $validate->delimiter_teplates(
508            report => 1,
509            current_input => 1,
510      );
511    
512    Options:
513    
514    =over 4
515    
516    =item report
517    
518    Generate humanly readable report with single fields
519    
520    =item current_input
521    
522    Report just current_input and not accumulated data
523    
524    =back
525    
526  =cut  =cut
527    
528  sub delimiters_templates {  sub delimiters_templates {
529          my $self = shift;          my $self = shift;
530    
531          my $t = $self->{_delimiters_templates};          my $args = {@_};
532    
533            my $t = $self->{_accumulated_delimiters_templates};
534            $t = $self->{_delimiters_templates} if ( $args->{current_input} );
535    
536          my $log = $self->_get_logger;          my $log = $self->_get_logger;
537    
538          unless ($t) {          unless ($t) {
539                  $log->warn("called without delimiters");                  $log->error("called without delimiters");
540                  return;                  return;
541          }          }
542    
543          my $out;          my $out;
544    
545          foreach my $f (sort { $a <=> $b } keys %$t) {          foreach my $f (sort { $a <=> $b } keys %$t) {
546                  $out .= "$f\n";                  $out .= "$f\n" if ( $args->{report} );
547                  foreach my $sft (sort { $a cmp $b } keys %{ $t->{$f} }) {                  foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
548                          $out .= "\t" . $t->{$f}->{$sft} . "\t$sft\n";                          my $count = $t->{$f}->{$template};
549                            $out .=
550                                    ( $count ? "" : "# " ) .
551                                    ( $args->{report} ? "" : "$f" ) .
552                                    "\t$count\t$template\n";
553                  }                  }
554          }          }
555    
556          return $out;          return $out;
557  }  }
558    
559    =head2 save_delimiters_templates
560    
561    Save accumulated delimiter templates
562    
563      $validator->save_delimiters_template( '/path/to/validate/delimiters' );
564    
565    =cut
566    
567    sub save_delimiters_templates {
568            my $self = shift;
569    
570            my $path = shift;
571            $path ||= $self->{delimiters_path};
572    
573            my $log = $self->_get_logger;
574    
575            $log->logdie("need path") unless ( $path );
576    
577    
578            if ( ! $self->{_accumulated_delimiters_templates} ) {
579                    $log->error('no _accumulated_delimiters_templates found, reset');
580                    $self->reset;
581            }
582    
583            if ( $self->{_delimiters_templates} ) {
584                    $log->error('found _delimiters_templates, calling reset');
585                    $self->reset;
586            }
587    
588            $path .= '.new' if ( -e $path );
589    
590            open(my $d, '>', $path) || $log->fatal("can't open $path: $!");
591            print $d $self->delimiters_templates;
592            close($d);
593    
594            $log->info("new delimiters templates saved to $path");
595    }
596    
597  =head1 AUTHOR  =head1 AUTHOR
598    
599  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.832  
changed lines
  Added in v.864
  ViewVC Help
Powered by ViewVC 1.1.26