/[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 625 by dpavlin, Sat Aug 26 12:00:36 2006 UTC
# Line 7  use blib; Line 7  use blib;
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
 use Text::Iconv;  
10  use Data::Dumper;  use Data::Dumper;
11    use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# 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.11
20    
21  =cut  =cut
22    
23  our $VERSION = '0.05';  our $VERSION = '0.11';
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 158  This function will read whole database i Line 159  This function will read whole database i
159    
160   $input->open(   $input->open(
161          path => '/path/to/database/file',          path => '/path/to/database/file',
162          code_page => '852',          code_page => 'cp852',
163          limit => 500,          limit => 500,
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<cp852>.
178    
179  C<offset> is optional parametar to position at some offset before reading from database.  C<offset> is optional parametar to position at some offset before reading from database.
180    
# 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'} || 'cp852';
209    
210          # store data in object          # store data in object
211          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 193  sub open { Line 213  sub open {
213                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
214          }          }
215    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});  
   
216          my $filter_ref;          my $filter_ref;
217            my $recode_regex;
218            my $recode_map;
219    
220          if ($self->{recode}) {          if ($self->{recode}) {
221                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
222                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
223                          $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)");
224                  } else {                  } else {
                         my $recode;  
225                          while (@r) {                          while (@r) {
226                                  my $from = shift @r;                                  my $from = shift @r;
227                                  my $to = shift @r;                                  my $to = shift @r;
228                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
229                          }                          }
230    
231                          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;  
                         };  
232    
233                            $log->debug("using recode regex: $recode_regex");
234                  }                  }
235    
236          }          }
237    
238            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
239            $log->debug("rec_regex: ", Dumper($rec_regex));
240    
241          my ($db, $size) = $self->{open_db}->( $self,          my ($db, $size) = $self->{open_db}->( $self,
242                  path => $arg->{path},                  path => $arg->{path},
243                  filter => $filter_ref,  #               filter => sub {
244    #                       my ($l,$f_nr) = @_;
245    #                       return unless defined($l);
246    #                       from_to($l, $code_page, $self->{'encoding'});
247    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
248    #                       return $l;
249    #               },
250                  %{ $arg },                  %{ $arg },
251          );          );
252    
# Line 259  sub open { Line 279  sub open {
279          # store size for later          # store size for later
280          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281    
282          $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]' : '');
283    
284          # read database          # read database
285          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
286    
287                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
288    
289                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
290                                    my ($l,$f_nr) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294                                    $log->debug("-=> $f_nr ## $l");
295    
296                                    # codepage conversion and recode_regex
297    #                               from_to($l, $code_page, $self->{'encoding'});
298                                    from_to($l, $code_page, 'utf-8');
299                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
300    
301                                    # apply regexps
302                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
303                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
304                                            my $c = 0;
305                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
306                                                    #$log->debug("\$l = $l\neval \$l =~ $r");
307                                                    eval '$l =~ ' . $r;
308                                                    $log->error("error applying regex: $r") if ($@);
309                                            }
310                                    }
311    
312                                    $log->debug("<=- $f_nr ## $l");
313                                    return $l;
314                    });
315    
316                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
317    
# Line 283  sub open { Line 328  sub open {
328                  }                  }
329    
330                  # create lookup                  # create lookup
331                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
332    
333                  # update counters for statistics                  # update counters for statistics
334                  if ($self->{stats}) {                  if ($self->{stats}) {
335                          map {  
336                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
337                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
338    
339                            foreach my $fld (keys %{ $rec }) {
340                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
341                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
342                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
343                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
344                                                          map {          
345                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
346                                                          } keys %{ $_ };  
347                                                  } else {                                          if (ref($row) eq 'HASH') {
348                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
349                                                    foreach my $sf (keys %{ $row }) {
350                                                            next if ($sf eq 'subfields');
351                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
352                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
353                                                                            if (ref($row->{$sf}) eq 'ARRAY');
354                                                  }                                                  }
355                                          } @{ $rec->{$fld} };  
356                                            } else {
357                                                    $self->{_stats}->{repeatable}->{ $fld }++;
358                                            }
359                                  }                                  }
360                          } keys %{ $rec };                          }
361                  }                  }
362    
363                  $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 512  sub stats {
512    
513                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
514                                  map {                                  map {
515                                          $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});                                          $o .= sprintf(" %s:%d%s", $_,
516                                                    $s->{sf}->{$f}->{$_}->{count},
517                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
518                                            );
519                                  } sort keys %{ $s->{sf}->{$f} };                                  } sort keys %{ $s->{sf}->{$f} };
520                          }                          }
521    
# Line 473  sub stats { Line 532  sub stats {
532          return $out;          return $out;
533  }  }
534    
535    =head2 modify_record_regexps
536    
537    Generate hash with regexpes to be applied using L<filter>.
538    
539      my $regexpes = $input->modify_record_regexps(
540                    900 => { '^a' => { ' : ' => '^b' } },
541                    901 => { '*' => { '^b' => ' ; ' } },
542      );
543    
544    =cut
545    
546    sub modify_record_regexps {
547            my $self = shift;
548            my $modify_record = {@_};
549    
550            my $regexpes;
551    
552            foreach my $f (keys %$modify_record) {
553    warn "--- f: $f\n";
554                    foreach my $sf (keys %{ $modify_record->{$f} }) {
555    warn "---- sf: $sf\n";
556                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
557                                    my $to = $modify_record->{$f}->{$sf}->{$from};
558                                    #die "no field?" unless defined($to);
559    warn "----- transform: |$from| -> |$to|\n";
560    
561                                    if ($sf =~ /^\^/) {
562                                            my $regex =
563                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
564                                            push @{ $regexpes->{$f} }, $regex;
565    warn ">>>>> $regex [sf]\n";
566                                    } else {
567                                            my $regex =
568                                                    's/\Q'. $from .'\E/'. $to .'/g';
569                                            push @{ $regexpes->{$f} }, $regex;
570    warn ">>>>> $regex [global]\n";
571                                    }
572    
573                            }
574                    }
575            }
576    
577            return $regexpes;
578    }
579    
580  =head1 MEMORY USAGE  =head1 MEMORY USAGE
581    
582  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 614  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
614    
615  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
616    
617  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
618    
619  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
620  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.523  
changed lines
  Added in v.625
  ViewVC Help
Powered by ViewVC 1.1.26