/[webpac2]/trunk/lib/WebPAC/Input.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/Input.pm

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

revision 596 by dpavlin, Sun Jul 9 15:22:39 2006 UTC revision 597 by dpavlin, Thu Jul 13 11:54:33 2006 UTC
# Line 39  C<fetch_rec> and optional C<init> functi Line 39  C<fetch_rec> and optional C<init> functi
39    
40  Perhaps a little code snippet.  Perhaps a little code snippet.
41    
42      use WebPAC::Input;          use WebPAC::Input;
43    
44      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 config => $config,  
46                  low_mem => 1,                  low_mem => 1,
47      );          );
48    
49      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
50          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
51          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
52                  # do something with $rec                  # do something with $rec
# Line 69  Create new input database object. Line 68  Create new input database object.
68          no_progress_bar => 1,          no_progress_bar => 1,
69    );    );
70    
71  C<module> is low-level file format module. See L<WebPAC::Input::Isis> and  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
73    
74  Optional parametar C<encoding> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
# Line 169  This function will read whole database i Line 168  This function will read whole database i
168                  my ($k,$v) = @_;                  my ($k,$v) = @_;
169                  # store lookup $k => $v                  # store lookup $k => $v
170          },          },
171            modify_records => {
172                    900 => { '^a' => { ' : ' => '^b' } },
173                    901 => { '*' => { '^b' => ' ; ' } },
174            },
175   );   );
176    
177  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<852>.
# Line 179  C<limit> is optional parametar to read j Line 182  C<limit> is optional parametar to read j
182    
183  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
184    
185  C<lookup_coderef> is closure to call when adding key => $value combinations to  C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
186  lookup.  lookup.
187    
188    C<modify_records> specify mapping from subfields to delimiters or from
189    delimiters to subfields, as well as oprations on fields (if subfield is
190    defined as C<*>.
191    
192  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
193  parametars, see also C<size>.  parametars, see also C<size>.
194    
# Line 210  sub open { Line 217  sub open {
217          $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!          $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!
218    
219          my $filter_ref;          my $filter_ref;
220            my $recode_regex;
221            my $recode_map;
222    
223          if ($self->{recode}) {          if ($self->{recode}) {
224                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
225                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
226                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");
227                  } else {                  } else {
                         my $recode;  
228                          while (@r) {                          while (@r) {
229                                  my $from = shift @r;                                  my $from = shift @r;
230                                  my $to = shift @r;                                  my $to = shift @r;
231                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
232                          }                          }
233    
234                          my $regex = join '|' => keys %{ $recode };                          $recode_regex = join '|' => keys %{ $recode_map };
   
                         $log->debug("using recode regex: $regex");  
                           
                         $filter_ref = sub {  
                                 my $t = shift;  
                                 $t =~ s/($regex)/$recode->{$1}/g;  
                                 return $t;  
                         };  
235    
236                            $log->debug("using recode regex: $recode_regex");
237                  }                  }
238    
239          }          }
240    
241            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
242            $log->debug("rec_regex: ", Dumper($rec_regex));
243    
244          my ($db, $size) = $self->{open_db}->( $self,          my ($db, $size) = $self->{open_db}->( $self,
245                  path => $arg->{path},                  path => $arg->{path},
246                  filter => $filter_ref,                  filter => sub {
247                                    my ($l,$f_nr) = @_;
248                                    return unless defined($l);
249    
250                                    ## FIXME remove iconv!
251                                    $l = $self->{iconv}->convert($l) if ($self->{iconv});
252            
253                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
254    
255                                    return $l unless ($rec_regex);
256    
257                                    # apply regexps
258                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
259                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
260                                            my $c = 0;
261                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
262                                                    while ( eval '$l =~ ' . $r ) { $c++ };
263                                            }
264                                            warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});
265                                    }
266    
267                                    return $l;
268                    },
269                  %{ $arg },                  %{ $arg },
270          );          );
271    
# Line 496  sub stats { Line 522  sub stats {
522          return $out;          return $out;
523  }  }
524    
525    =head1 modify_record_regexps
526    
527    Generate hash with regexpes to be applied using L<filter>.
528    
529      my $regexpes = $input->modify_record_regexps(
530                    900 => { '^a' => { ' : ' => '^b' } },
531                    901 => { '*' => { '^b' => ' ; ' } },
532      );
533    
534    =cut
535    
536    sub modify_record_regexps {
537            my $self = shift;
538            my $modify_record = {@_};
539    
540            my $regexpes;
541    
542            foreach my $f (keys %$modify_record) {
543    warn "--- f: $f\n";
544                    foreach my $sf (keys %{ $modify_record->{$f} }) {
545    warn "---- sf: $sf\n";
546                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
547                                    my $to = $modify_record->{$f}->{$sf}->{$from};
548                                    #die "no field?" unless defined($to);
549    warn "----- transform: |$from| -> |$to|\n";
550    
551                                    if ($sf =~ /^\^/) {
552                                            my $regex =
553                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
554                                            push @{ $regexpes->{$f} }, $regex;
555    warn ">>>>> $regex [sf]\n";
556                                    } else {
557                                            my $regex =
558                                                    's/\Q'. $from .'\E/'. $to .'/g';
559                                            push @{ $regexpes->{$f} }, $regex;
560    warn ">>>>> $regex [global]\n";
561                                    }
562    
563                            }
564                    }
565            }
566    
567            return $regexpes;
568    }
569    
570  =head1 MEMORY USAGE  =head1 MEMORY USAGE
571    
572  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
Legend:
Removed from v.596  
changed lines
  Added in v.597
  ViewVC Help
Powered by ViewVC 1.1.26