/[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 828 by dpavlin, Sun May 20 16:19:17 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} }) . ')';  }
                 $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  }  }
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                                          warn "## v = ", dump( $v );                                  my $l = _pack_subfields_hash( $v, 1 );
228                                          my $l = _pack_subfields_hash( $v, 1 );                                  my $subfield_dump = $l;
229                                          warn "## $l [$regex]\n";                                  my $template = '';
230                                          my $template = '';                                  $l =~ s/$regex/$template.=$1/eg;
231                                          $l =~ s/$regex/$template.=$1/eg && warn "## new: $l\n";                                  #warn "## template: $template\n";
232                                          warn "## template: $template\n";  
233                                          $self->{_delimiters_templates}->{$f}->{$template}++ if ( $template );                                  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 247  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 258  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 267  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 and remember delimiter templates
349    for L<save_delimiters_templates>
350    
351  Clean all accumulated errors for this input    $validate->reset;
352    
353    $validate->reset_errors;  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 328  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 338  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 362  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 407  sub report { Line 499  sub report {
499    
500  }  }
501    
502    =head2 delimiters_templates
503    
504    Generate report of delimiter tamplates
505    
506      my $report = $validate->delimiter_teplates(
507            report => 1,
508            current_input => 1,
509      );
510    
511    Options:
512    
513    =over 4
514    
515    =item report
516    
517    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
524    
525    =cut
526    
527    sub delimiters_templates {
528            my $self = shift;
529    
530            my $args = {@_};
531    
532            my $t = $self->{_accumulated_delimiters_templates};
533            $t = $self->{_delimiters_templates} if ( $args->{current_input} );
534    
535            my $log = $self->_get_logger;
536    
537            unless ($t) {
538                    $log->error("called without delimiters");
539                    return;
540            }
541    
542            my $out;
543    
544            foreach my $f (sort { $a <=> $b } keys %$t) {
545                    $out .= "$f\n" if ( $args->{report} );
546                    foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
547                            my $count = $t->{$f}->{$template};
548                            $out .=
549                                    ( $count ? "" : "# " ) .
550                                    ( $args->{report} ? "" : "$f" ) .
551                                    "\t$count\t$template\n";
552                    }
553            }
554    
555            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.828  
changed lines
  Added in v.858
  ViewVC Help
Powered by ViewVC 1.1.26