/[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 523 by dpavlin, Sun May 21 19:29:26 2006 UTC revision 606 by dpavlin, Tue Aug 1 13:59:47 2006 UTC
# Line 16  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.05  Version 0.09
20    
21  =cut  =cut
22    
23  our $VERSION = '0.05';  our $VERSION = '0.09';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# 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,  
                 lookup => $lookup_obj,  
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 64  Create new input database object. Line 62  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
65          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
66          low_mem => 1,          low_mem => 1,
67          recode => 'char pairs',          recode => 'char pairs',
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<code_page> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
75  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
76  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
77    
# Line 96  sub new { Line 94  sub new {
94    
95          my $log = $self->_get_logger;          my $log = $self->_get_logger;
96    
97            $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
99    
100          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
101          my $module = $self->{module};          my $module = $self->{module};
102          $module =~ s#::#/#g;          $module =~ s#::#/#g;
# Line 121  sub new { Line 122  sub new {
122                  $self->{init}->($self, @_);                  $self->{init}->($self, @_);
123          }          }
124    
125          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
126    
127          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
128          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 163  This function will read whole database i Line 164  This function will read whole database i
164          offset => 6000,          offset => 6000,
165          lookup => $lookup_obj,          lookup => $lookup_obj,
166          stats => 1,          stats => 1,
167            lookup_ref => sub {
168                    my ($k,$v) = @_;
169                    # 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 173  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 C<< key => 'value' >> combinations to
186    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 184  sub open { Line 200  sub open {
200    
201          my $log = $self->_get_logger();          my $log = $self->_get_logger();
202    
203            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
204            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
205                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
206    
207          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
208          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
209    
# Line 194  sub open { Line 214  sub open {
214          }          }
215    
216          # create Text::Iconv object          # create Text::Iconv object
217          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          $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                                    ## FIXME remove this warning when we are sure that none of API is calling
256                                    ## this wrongly
257                                    #warn "filter called without field number" unless ($f_nr);
258    
259                                    return $l unless ($rec_regex && $f_nr);
260    
261                                    # apply regexps
262                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
263                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
264                                            my $c = 0;
265                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
266                                                    while ( eval '$l =~ ' . $r ) { $c++ };
267                                            }
268                                            warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});
269                                    }
270    
271                                    return $l;
272                    },
273                  %{ $arg },                  %{ $arg },
274          );          );
275    
# Line 259  sub open { Line 302  sub open {
302          # store size for later          # store size for later
303          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
304    
305          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
306    
307          # read database          # read database
308          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
# Line 283  sub open { Line 326  sub open {
326                  }                  }
327    
328                  # create lookup                  # create lookup
329                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
330    
331                  # update counters for statistics                  # update counters for statistics
332                  if ($self->{stats}) {                  if ($self->{stats}) {
333                          map {  
334                                  my $fld = $_;                          foreach my $fld (keys %{ $rec }) {
335                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
336                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
337                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
338                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
339                                                          map {          
340                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
341                                                          } keys %{ $_ };  
342                                                  } else {                                          if (ref($row) eq 'HASH') {
343                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
344                                                    foreach my $sf (keys %{ $row }) {
345                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
346                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
347                                                                            if (ref($row->{$sf}) eq 'ARRAY');
348                                                  }                                                  }
349                                          } @{ $rec->{$fld} };  
350                                            } else {
351                                                    $self->{_stats}->{repeatable}->{ $fld }++;
352                                            }
353                                  }                                  }
354                          } keys %{ $rec };                          }
355                  }                  }
356    
357                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 456  sub stats { Line 506  sub stats {
506    
507                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
508                                  map {                                  map {
509                                          $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});                                          $o .= sprintf(" %s:%d%s", $_,
510                                                    $s->{sf}->{$f}->{$_}->{count},
511                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
512                                            );
513                                  } sort keys %{ $s->{sf}->{$f} };                                  } sort keys %{ $s->{sf}->{$f} };
514                          }                          }
515    
# Line 473  sub stats { Line 526  sub stats {
526          return $out;          return $out;
527  }  }
528    
529    =head2 modify_record_regexps
530    
531    Generate hash with regexpes to be applied using L<filter>.
532    
533      my $regexpes = $input->modify_record_regexps(
534                    900 => { '^a' => { ' : ' => '^b' } },
535                    901 => { '*' => { '^b' => ' ; ' } },
536      );
537    
538    =cut
539    
540    sub modify_record_regexps {
541            my $self = shift;
542            my $modify_record = {@_};
543    
544            my $regexpes;
545    
546            foreach my $f (keys %$modify_record) {
547    warn "--- f: $f\n";
548                    foreach my $sf (keys %{ $modify_record->{$f} }) {
549    warn "---- sf: $sf\n";
550                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
551                                    my $to = $modify_record->{$f}->{$sf}->{$from};
552                                    #die "no field?" unless defined($to);
553    warn "----- transform: |$from| -> |$to|\n";
554    
555                                    if ($sf =~ /^\^/) {
556                                            my $regex =
557                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
558                                            push @{ $regexpes->{$f} }, $regex;
559    warn ">>>>> $regex [sf]\n";
560                                    } else {
561                                            my $regex =
562                                                    's/\Q'. $from .'\E/'. $to .'/g';
563                                            push @{ $regexpes->{$f} }, $regex;
564    warn ">>>>> $regex [global]\n";
565                                    }
566    
567                            }
568                    }
569            }
570    
571            return $regexpes;
572    }
573    
574  =head1 MEMORY USAGE  =head1 MEMORY USAGE
575    
576  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
# Line 510  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 608  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
608    
609  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
610    
611  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
612    
613  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
614  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.523  
changed lines
  Added in v.606
  ViewVC Help
Powered by ViewVC 1.1.26